Ejercicio – Página 7

Raíces digitales de potencias de dos

PorJosé A. Alonso 7-abril-202114-abril-2021

La raíz digital de un número entero positivo n es el dígito resulta al sumar sus dígitos, volviendo a sumar reiteradamente los resultados de esa suma y de las siguientes hasta que la suma sea un número de un dígito, al que se llama la raíz digital del número n y se representa por D(n). Por ejemplo, la raíz digital del número 23451 es 6, porque 2+3+4+5+1 = 15 y sumando los dígitos del 15 resulta 6.

Definir la función

   raizDigitalPotencia :: Integer -> Integer

1	raizDigitalPotencia :: Integer -> Integer

tal que (raizDigitalPotencia n) es la raíz digital de 2^n. Por ejemplo,

   raizDigitalPotencia 6            ==  1
   raizDigitalPotencia (10^(10^8))  ==  7

1 2	raizDigitalPotencia 6 == 1 raizDigitalPotencia (10^(10^8)) == 7

Soluciones

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

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

raizDigitalPotencia :: Integer -> Integer
raizDigitalPotencia n =
  raizDigital (2^n)

-- (raizDigital n) es la raíz digital de n. Por ejemplo,
--    raizDigital 23451  ==  6
raizDigital :: Integer -> Integer
raizDigital n = 1 + (n-1) `mod` 9

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

-- Calculando las raíces digitales de los primeros números se obtiene
--    λ> map raizDigitalPotencia [0..29]
--    [1,2,4,8,7,5,1,2,4,8,7,5,1,2,4,8,7,5,1,2,4,8,7,5,1,2,4,8,7,5]
-- Se observa se repite el período 1,2,4,8,7,5.

raizDigitalPotencia2 :: Integer -> Integer
raizDigitalPotencia2 n
    | m == 0 = 1
    | m == 1 = 2
    | m == 2 = 4
    | m == 3 = 8
    | m == 4 = 7
    | m == 5 = 5
  where m = n `mod` 6

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

raizDigitalPotencia3 :: Integer -> Integer
raizDigitalPotencia3 n =
  case (n `mod` 6) of
    0 -> 1
    1 -> 2
    2 -> 4
    3 -> 8
    4 -> 7
    5 -> 5

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

raizDigitalPotencia4 :: Integer -> Integer
raizDigitalPotencia4 n =
  raizDigital (2^(mod n 6))

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

-- La propiedad es
prop_raizDigitalPotencia :: Integer -> Property
prop_raizDigitalPotencia n =
  n >= 0 ==>
  all (== (raizDigitalPotencia n))
      [raizDigitalPotencia2 n,
       raizDigitalPotencia3 n,
       raizDigitalPotencia4 n]

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

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

-- La comparación es
--    λ> raizDigitalPotencia 300000000
--    1
--    (2.82 secs, 149,107,152 bytes)
--    λ> raizDigitalPotencia2 300000000
--    1
--    (0.01 secs, 98,480 bytes)
--    λ> raizDigitalPotencia3 300000000
--    1
--    (0.01 secs, 98,440 bytes)
--    λ> raizDigitalPotencia4 300000000
--    1
--    (0.01 secs, 98,568 bytes)
--
--    λ> raizDigitalPotencia2 (10^(10^8))
--    7
--    (3.09 secs, 123,233,992 bytes)
--    λ> raizDigitalPotencia3 (10^(10^8))
--    7
--    (3.07 secs, 123,232,728 bytes)
--    λ> raizDigitalPotencia4 (10^(10^8))
--    7
--    (3.18 secs, 123,234,344 bytes)

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

-- 1ª solución

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

raizDigitalPotencia :: Integer -> Integer

raizDigitalPotencia n =

raizDigital (2^n)

-- (raizDigital n) es la raíz digital de n. Por ejemplo,

-- raizDigital 23451 == 6

raizDigital :: Integer -> Integer

raizDigital n = 1 + (n-1) `mod` 9

-- 2ª solución

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

-- Calculando las raíces digitales de los primeros números se obtiene

-- λ> map raizDigitalPotencia [0..29]

-- [1,2,4,8,7,5,1,2,4,8,7,5,1,2,4,8,7,5,1,2,4,8,7,5,1,2,4,8,7,5]

-- Se observa se repite el período 1,2,4,8,7,5.

raizDigitalPotencia2 :: Integer -> Integer

raizDigitalPotencia2 n

| m == 0 = 1

| m == 1 = 2

| m == 2 = 4

| m == 3 = 8

| m == 4 = 7

| m == 5 = 5

where m = n `mod` 6

-- 3ª solución

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

raizDigitalPotencia3 :: Integer -> Integer

raizDigitalPotencia3 n =

case (n `mod` 6) of

0 -> 1

1 -> 2

2 -> 4

3 -> 8

4 -> 7

5 -> 5

-- 4ª solución

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

raizDigitalPotencia4 :: Integer -> Integer

raizDigitalPotencia4 n =

raizDigital (2^(mod n 6))

-- Comprobación de equivalencia

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

-- La propiedad es

prop_raizDigitalPotencia :: Integer -> Property

prop_raizDigitalPotencia n =

n >= 0 ==>

all (== (raizDigitalPotencia n))

[raizDigitalPotencia2 n,

raizDigitalPotencia3 n,

raizDigitalPotencia4 n]

-- La comprobación es

-- λ> quickCheck prop_raizDigitalPotencia

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> raizDigitalPotencia 300000000

-- 1

-- (2.82 secs, 149,107,152 bytes)

-- λ> raizDigitalPotencia2 300000000

-- 1

-- (0.01 secs, 98,480 bytes)

-- λ> raizDigitalPotencia3 300000000

-- 1

-- (0.01 secs, 98,440 bytes)

-- λ> raizDigitalPotencia4 300000000

-- 1

-- (0.01 secs, 98,568 bytes)

-- λ> raizDigitalPotencia2 (10^(10^8))

-- 7

-- (3.09 secs, 123,233,992 bytes)

-- λ> raizDigitalPotencia3 (10^(10^8))

-- 7

-- (3.07 secs, 123,232,728 bytes)

-- λ> raizDigitalPotencia4 (10^(10^8))

-- 7

-- (3.18 secs, 123,234,344 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>

Raíz digital

PorJosé A. Alonso 6-abril-202113-abril-2021

La raíz digital de un número entero positivo n es el dígito que resulta al sumar sus dígitos, volviendo a sumar reiteradamente los resultados de esa suma y de las siguientes hasta que la suma sea un número de un dígito, al que se llama la raíz digital del número n y se representa por D(n). Por ejemplo, la raíz digital del número 23451 es 6, porque 2+3+4+5+1 = 15 y sumando los dígitos del 15 resulta 6.

Definir la función

   raizDigital :: Integer -> Integer

1	raizDigital :: Integer -> Integer

tal que (raizDigital n) es la raíz digital del entero positivo n. Por ejemplo,

   raizDigital 23451  ==  6

1	raizDigital 23451 == 6

Comprobar con QuickCheck las siguientes propiedades de la raíz digital:

D(m + n) = D(D(m) + D(n)).
D(mn) = D(D(m)D(n)).
D(m^n) = D(D(m)^n).
D(D(n)) = D(n).
D(n + 9) = D(n).
D(9n) = 9.

Soluciones

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

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

raizDigital :: Integer -> Integer
raizDigital n
  | n < 10    = n
  | otherwise = raizDigital (sumaDigitos n)

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

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

raizDigital2 :: Integer -> Integer
raizDigital2 n =
  head (dropWhile (>9) (iterate sumaDigitos n))

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

raizDigital3 :: Integer -> Integer
raizDigital3 n
  | m == 0    = 9
  | otherwise = m
  where m = n `mod` 9

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

raizDigital4 :: Integer -> Integer
raizDigital4 n = 1 + (n-1) `mod` 9

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

-- La propiedad es
prop_raizDigital_equiv :: Integer -> Property
prop_raizDigital_equiv n =
  n > 0 ==>
  all (== (raizDigital n))
      [raizDigital2 n,
       raizDigital3 n,
       raizDigital4 n]

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

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

-- Las propiedades son
prop_raizDigital :: Integer -> Integer -> Property
prop_raizDigital m n =
  m > 0 && n > 0 ==>
  d(m + n) == d(d(m) + d(n)) &&
  d(m*n) == d(d(m)*d(n)) &&
  d(m^n) == d(d(m)^n) &&
  d(d(n)) == d(n) &&
  d(n + 9) == d(n) &&
  d(9*n) == 9
  where d = raizDigital

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

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

-- 1ª solución

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

raizDigital :: Integer -> Integer

raizDigital n

| n < 10 = n

| otherwise = raizDigital (sumaDigitos n)

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

-- 2ª solución

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

raizDigital2 :: Integer -> Integer

raizDigital2 n =

head (dropWhile (>9) (iterate sumaDigitos n))

-- 3ª solución

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

raizDigital3 :: Integer -> Integer

raizDigital3 n

| m == 0 = 9

| otherwise = m

where m = n `mod` 9

-- 4ª solución

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

raizDigital4 :: Integer -> Integer

raizDigital4 n = 1 + (n-1) `mod` 9

-- Comprobación de equivalencia

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

-- La propiedad es

prop_raizDigital_equiv :: Integer -> Property

prop_raizDigital_equiv n =

n > 0 ==>

all (== (raizDigital n))

[raizDigital2 n,

raizDigital3 n,

raizDigital4 n]

-- La comprobación es

-- λ> quickCheck prop_raizDigital_equiv

-- +++ OK, passed 100 tests.

-- Propiedades

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

-- Las propiedades son

prop_raizDigital :: Integer -> Integer -> Property

prop_raizDigital m n =

m > 0 && n > 0 ==>

d(m + n) == d(d(m) + d(n)) &&

d(m*n) == d(d(m)*d(n)) &&

d(m^n) == d(d(m)^n) &&

d(d(n)) == d(n) &&

d(n + 9) == d(n) &&

d(9*n) == 9

where d = raizDigital

-- La comprobación es

-- λ> quickCheck prop_raizDigital

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

Antiimágenes de funciones crecientes bidimensionales

PorJosé A. Alonso 5-abril-202129-marzo-2021

Una función f de pares de números naturales en números naturales es estrictamente creciente en ambos argumentos si

para x1 < x2, se tiene f(x1,y) < f(x1,y), para todo y y
para y1 < y2, se tiene f(x,y1) < f(x,y2), para todo x.

Por ejemplo, la función f definida por f(x,y) = x^2+3^y es creciente en ambos argumentos.

Las antiimágenes por f de t son los pares (x,y) tales que f(x,y) = t. Por ejemplo, las antimágenes por f(x,y) = x^2+3^y de 82 son los pares (1,4) y (9,0).

Definir la función

   antiimagenes :: Integral a => ((a,a) -> a) -> a -> [(a,a)]

1	antiimagenes :: Integral a => ((a,a) -> a) -> a -> [(a,a)]

tal que (antiimagenes f t) es la lista de las antiimágenes por f de t, donde se supone que f es una función de pares de números naturales en números naturales que es estrictamente creciente en ambos argumentos. Por ejemplo,

   antiimagenes (\(x,y) -> x^2+3^y) 82        ==  [(1,4),(9,0)]
   antiimagenes (\(x,y) -> x^2+3^y) 387421785 ==  [(36,18)]

1 2	antiimagenes (\(x,y) -> x^2+3^y) 82 == [(1,4),(9,0)] antiimagenes (\(x,y) -> x^2+3^y) 387421785 == [(36,18)]

Soluciones

[schedule expon=’2021-04-12′ expat=»06:00″]

Las soluciones se pueden escribir en los comentarios hasta el 12 de abril.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

[/schedule]

[schedule on=’2021-04-12′ at=»06:00″]

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

antiimagenes :: Integral a => ((a,a) -> a) -> a -> [(a,a)]
antiimagenes f t =
  [(x,y) | x <- [0..t], y <- [0..t ], f (x,y) == t]

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

antiimagenes2 :: Integral a => ((a,a) -> a) -> a -> [(a,a)]
antiimagenes2 f t = antiimagenesEn (0,t)
  where antiimagenesEn (a,b) = [(x,y) | x <- [a..t], y <- [b,b-1..0], f (x,y) == t]

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

antiimagenes3 :: Integral a => ((a,a) -> a) -> a -> [(a,a)]
antiimagenes3 f t = antiimagenesEn (0,t)
  where antiimagenesEn (a,b)
          | a > t || b < 0 = []
          | c < t          = antiimagenesEn (a+1,b)
          | c == t         = (a,b) : antiimagenesEn (a+1,b-1)
          | c > t          = antiimagenesEn (a,b-1)
          where c = f (a,b)

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

antiimagenes4 :: Integral a => ((a,a) -> a) -> a -> [(a,a)]
antiimagenes4 f t = desde (0,p) (q,0) where
  p = menor (-1,t) (\ y -> f (0,y)) t
  q = menor (-1,t) (\ x -> f (x,0)) t
  desde (x1,y1) (x2,y2)
    | x2 < x1 || y1 < y2 = []
    | y1 - y <= x2 - x1  = fila x
    | otherwise          = columna y
    where
      x = menor (x1-1,x2) (\ x -> f (x,r)) t
      y = menor (y2-1,y1) (\ y -> f (c,y)) t
      c = (x1 + x2) `div` 2
      r = (y1 + y2) `div` 2
      fila x
        | z < t  = desde (x1,y1) (x2,r+1)
        | z == t = (x,r) : desde (x1,y1) (x-1,r+1) ++ desde (x+1,r-1) (x2,y2)
        | z > t  = desde (x1,y1) (x-1,r+1) ++ desde (x,r-1) (x2,y2)
        where z = f (x,r)
      columna y
        | z < t  = desde (c+1,y1) (x2,y2)
        | z == t = (c,y) : desde (x1,y1) (c-1,y+1) ++ desde (c+1,y-1) (x2,y2)
        | z > t  = desde (x1,y1) (c-1,y) ++ desde (c+1,y-1) (x2,y2)
        where z = f (c, y)


-- (menor (a,b) f t), suponiendo que t <= f b, es el menor x enel
-- intervalo (a,b] tal que t <= f x.
menor :: Integral a => (a,a) -> (a -> a) -> a -> a
menor (a,b) f t
  | a + 1 == b = b
  | t <= f m   = menor (a, m) f t
  | otherwise  = menor (m, b) f t
  where m = (a + b) `div` 2

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

-- La comparación es
--    λ> antiimagenes (\(x,y) -> x^2+3^y) 2383
--    [(14,7)]
--    (15.63 secs, 26,904,500,208 bytes)
--    λ> antiimagenes2 (\(x,y) -> x^2+3^y) 2383
--    [(14,7)]
--    (16.37 secs, 26,950,312,440 bytes)
--    λ> antiimagenes3 (\(x,y) -> x^2+3^y) 2383
--    [(14,7)]
--    (0.03 secs, 11,892,160 bytes)
--    λ> antiimagenes4 (\(x,y) -> x^2+3^y) 2383
--    [(14,7)]
--    (0.01 secs, 277,696 bytes)
--
--    λ> antiimagenes3 (\(x,y) -> x^2+3^y) 59449
--    [(20,10)]
--    (3.77 secs, 1,329,803,208 bytes)
--    λ> antiimagenes4 (\(x,y) -> x^2+3^y) 59449
--    [(20,10)]
--    (0.03 secs, 400,400 bytes)

-- 1ª solución

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

antiimagenes :: Integral a => ((a,a) -> a) -> a -> [(a,a)]

antiimagenes f t =

[(x,y) | x <- [0..t], y <- [0..t ], f (x,y) == t]

-- 2ª solución

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

antiimagenes2 :: Integral a => ((a,a) -> a) -> a -> [(a,a)]

antiimagenes2 f t = antiimagenesEn (0,t)

where antiimagenesEn (a,b) = [(x,y) | x <- [a..t], y <- [b,b-1..0], f (x,y) == t]

-- 3ª solución

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

antiimagenes3 :: Integral a => ((a,a) -> a) -> a -> [(a,a)]

antiimagenes3 f t = antiimagenesEn (0,t)

where antiimagenesEn (a,b)

| a > t || b < 0 = []

| c < t = antiimagenesEn (a+1,b)

| c == t = (a,b) : antiimagenesEn (a+1,b-1)

| c > t = antiimagenesEn (a,b-1)

where c = f (a,b)

-- 3ª solución

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

antiimagenes4 :: Integral a => ((a,a) -> a) -> a -> [(a,a)]

antiimagenes4 f t = desde (0,p) (q,0) where

p = menor (-1,t) (\ y -> f (0,y)) t

q = menor (-1,t) (\ x -> f (x,0)) t

desde (x1,y1) (x2,y2)

| x2 < x1 || y1 < y2 = []

| y1 - y <= x2 - x1 = fila x

| otherwise = columna y

where

x = menor (x1-1,x2) (\ x -> f (x,r)) t

y = menor (y2-1,y1) (\ y -> f (c,y)) t

c = (x1 + x2) `div` 2

r = (y1 + y2) `div` 2

fila x

| z < t = desde (x1,y1) (x2,r+1)

| z == t = (x,r) : desde (x1,y1) (x-1,r+1) ++ desde (x+1,r-1) (x2,y2)

| z > t = desde (x1,y1) (x-1,r+1) ++ desde (x,r-1) (x2,y2)

where z = f (x,r)

columna y

| z < t = desde (c+1,y1) (x2,y2)

| z == t = (c,y) : desde (x1,y1) (c-1,y+1) ++ desde (c+1,y-1) (x2,y2)

| z > t = desde (x1,y1) (c-1,y) ++ desde (c+1,y-1) (x2,y2)

where z = f (c, y)

-- (menor (a,b) f t), suponiendo que t <= f b, es el menor x enel

-- intervalo (a,b] tal que t <= f x.

menor :: Integral a => (a,a) -> (a -> a) -> a -> a

menor (a,b) f t

| a + 1 == b = b

| t <= f m = menor (a, m) f t

| otherwise = menor (m, b) f t

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

-- Comparación de eficiencia

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

-- La comparación es

-- λ> antiimagenes (\(x,y) -> x^2+3^y) 2383

-- [(14,7)]

-- (15.63 secs, 26,904,500,208 bytes)

-- λ> antiimagenes2 (\(x,y) -> x^2+3^y) 2383

-- [(14,7)]

-- (16.37 secs, 26,950,312,440 bytes)

-- λ> antiimagenes3 (\(x,y) -> x^2+3^y) 2383

-- [(14,7)]

-- (0.03 secs, 11,892,160 bytes)

-- λ> antiimagenes4 (\(x,y) -> x^2+3^y) 2383

-- [(14,7)]

-- (0.01 secs, 277,696 bytes)

-- λ> antiimagenes3 (\(x,y) -> x^2+3^y) 59449

-- [(20,10)]

-- (3.77 secs, 1,329,803,208 bytes)

-- λ> antiimagenes4 (\(x,y) -> x^2+3^y) 59449

-- [(20,10)]

-- (0.03 secs, 400,400 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>

[/schedule]

Antiimagen de función creciente

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

Una función f de los números naturales en los números naturales es estrictamente creciente si para cualquier par de números x, y tales que x < y se verifica que f(x) < f(y). La antiimagen por f de un número natural t es el número natural x tal que f(x) = t. No todos los números tienen antiimiagen por f, pero en caso de tenerla es única.

Definir la función

   antiimagen :: (Integer -> Integer) -> Integer -> Maybe Integer

1	antiimagen :: (Integer -> Integer) -> Integer -> Maybe Integer

tal que, suponiendo que f es una función creciente de los números naturales en los números naturales, (antiimagen f t) es justamente la antiimagen por f de t, si existe y es Nothing, en caso contrario. Por ejemplo,

   antiimagen (\x -> 2*x^2-3) 47  ==  Just 5
   antiimagen (\x -> 2*x^2-3) 48  ==  Nothing
   antiimagen (\x -> 2^x) 1024    ==  Just 10
   antiimagen (2^) 1024           ==  Just 10
   antiimagen (2^) (2^(10^7))     ==  Just 10000000
   antiimagen (2^) (1+2^(10^7))   ==  Nothing

antiimagen (\x -> 2*x^2-3) 47 == Just 5

antiimagen (\x -> 2*x^2-3) 48 == Nothing

antiimagen (\x -> 2^x) 1024 == Just 10

antiimagen (2^) 1024 == Just 10

antiimagen (2^) (2^(10^7)) == Just 10000000

antiimagen (2^) (1+2^(10^7)) == Nothing

Soluciones

import Data.Maybe (listToMaybe)

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

antiimagen :: (Integer -> Integer) -> Integer -> Maybe Integer
antiimagen f t =
  listToMaybe [x | x <- [0..t], f x == t]

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

antiimagen2 :: (Integer -> Integer) -> Integer -> Maybe Integer
antiimagen2 f t = busqueda (0,t)
  where busqueda (a,b) = listToMaybe [x | x <- [a..b], f x == t]

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

antiimagen3 :: (Integer -> Integer) -> Integer -> Maybe Integer
antiimagen3 f t = busqueda (0,t)
  where busqueda (a,b)
          | a > b     = Nothing
          | t < f m   = busqueda (a,m-1)
          | t == f m  = Just m
          | otherwise = busqueda (m+1,b)
          where m = (a+b) `div` 2

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

antiimagen4 :: (Integer -> Integer) -> Integer -> Maybe Integer
antiimagen4 f t | f x == t  = Just x
                | otherwise = Nothing
  where x = busqueda (cotas f t)
        busqueda (a,b) = head [x | x <- [a+1..b], t <= f x]

-- (cotas f t) es un par (a,b) de potencias consecutivas de 2 tal que la
-- antiimagen de t por f está en el intevalo [a+1,b]. Por ejemplo,
--    cotas (\x -> 2*x^2-3) 47  ==  (4,8)
--    cotas (\x -> 2^x) 1024    ==  (8,16)
cotas :: (Integer -> Integer) -> Integer -> (Integer, Integer)
cotas f t | t <= f 0  = (-1,0)
          | otherwise = (b `div` 2, b)
  where b = until done (*2) 1
        done b = t <= f b

-- 5ª solución
-- ===========

antiimagen5 :: (Integer -> Integer) -> Integer -> Maybe Integer
antiimagen5 f t | f x == t  = Just x
                | otherwise = Nothing
  where x = busqueda (cotas f t)
        busqueda (a,b) | a+1 == b  = b
                       | t <= f m  = busqueda (a,m)
                       | otherwise = busqueda (m,b)
          where m = (a+b) `div`  2

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

-- La comparación es
--    λ> antiimagen (2^) (2^30)
--    Just 30
--    (0.01 secs, 142,728 bytes)
--    λ> antiimagen2 (2^) (2^30)
--    Just 30
--    (0.01 secs, 142,784 bytes)
--    λ> antiimagen3 (2^) (2^30)
--    Just 30
--    (8.05 secs, 335,820,048 bytes)
--    λ> antiimagen4 (2^) (2^30)
--    Just 30
--    (0.01 secs, 133,984 bytes)
--    λ> antiimagen5 (2^) (2^30)
--    Just 30
--    (0.02 secs, 121,816 bytes)
--
--    λ> antiimagen (2^) (2^50000)
--    Just 50000
--    (1.29 secs, 673,789,160 bytes)
--    λ> antiimagen2 (2^) (2^50000)
--    Just 50000
--    (1.28 secs, 673,791,368 bytes)
--    λ> antiimagen4 (2^) (2^50000)
--    Just 50000
--    (0.84 secs, 342,311,360 bytes)
--    λ> antiimagen5 (2^) (2^50000)
--    Just 50000
--    (0.01 secs, 549,688 bytes)
--
--    λ> antiimagen4 (2^) (2^100000)
--    Just 100000
--    (4.37 secs, 1,210,476,848 bytes)
--    λ> antiimagen5 (2^) (2^100000)
--    Just 100000
--    (0.01 secs, 918,096 bytes)

import Data.Maybe (listToMaybe)

-- 1ª solución

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

antiimagen :: (Integer -> Integer) -> Integer -> Maybe Integer

antiimagen f t =

listToMaybe [x | x <- [0..t], f x == t]

-- 2ª solución

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

antiimagen2 :: (Integer -> Integer) -> Integer -> Maybe Integer

antiimagen2 f t = busqueda (0,t)

where busqueda (a,b) = listToMaybe [x | x <- [a..b], f x == t]

-- 3ª solución

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

antiimagen3 :: (Integer -> Integer) -> Integer -> Maybe Integer

antiimagen3 f t = busqueda (0,t)

where busqueda (a,b)

| a > b = Nothing

| t < f m = busqueda (a,m-1)

| t == f m = Just m

| otherwise = busqueda (m+1,b)

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

-- 4ª solución

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

antiimagen4 :: (Integer -> Integer) -> Integer -> Maybe Integer

antiimagen4 f t | f x == t = Just x

| otherwise = Nothing

where x = busqueda (cotas f t)

busqueda (a,b) = head [x | x <- [a+1..b], t <= f x]

-- (cotas f t) es un par (a,b) de potencias consecutivas de 2 tal que la

-- antiimagen de t por f está en el intevalo [a+1,b]. Por ejemplo,

-- cotas (\x -> 2*x^2-3) 47 == (4,8)

-- cotas (\x -> 2^x) 1024 == (8,16)

cotas :: (Integer -> Integer) -> Integer -> (Integer, Integer)

cotas f t | t <= f 0 = (-1,0)

| otherwise = (b `div` 2, b)

where b = until done (*2) 1

done b = t <= f b

-- 5ª solución

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

antiimagen5 :: (Integer -> Integer) -> Integer -> Maybe Integer

antiimagen5 f t | f x == t = Just x

| otherwise = Nothing

where x = busqueda (cotas f t)

busqueda (a,b) | a+1 == b = b

| t <= f m = busqueda (a,m)

| otherwise = busqueda (m,b)

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

-- Comparación de eficiencia

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

-- La comparación es

-- λ> antiimagen (2^) (2^30)

-- Just 30

-- (0.01 secs, 142,728 bytes)

-- λ> antiimagen2 (2^) (2^30)

-- Just 30

-- (0.01 secs, 142,784 bytes)

-- λ> antiimagen3 (2^) (2^30)

-- Just 30

-- (8.05 secs, 335,820,048 bytes)

-- λ> antiimagen4 (2^) (2^30)

-- Just 30

-- (0.01 secs, 133,984 bytes)

-- λ> antiimagen5 (2^) (2^30)

-- Just 30

-- (0.02 secs, 121,816 bytes)

-- λ> antiimagen (2^) (2^50000)

-- Just 50000

-- (1.29 secs, 673,789,160 bytes)

-- λ> antiimagen2 (2^) (2^50000)

-- Just 50000

-- (1.28 secs, 673,791,368 bytes)

-- λ> antiimagen4 (2^) (2^50000)

-- Just 50000

-- (0.84 secs, 342,311,360 bytes)

-- λ> antiimagen5 (2^) (2^50000)

-- Just 50000

-- (0.01 secs, 549,688 bytes)

-- λ> antiimagen4 (2^) (2^100000)

-- Just 100000

-- (4.37 secs, 1,210,476,848 bytes)

-- λ> antiimagen5 (2^) (2^100000)

-- Just 100000

-- (0.01 secs, 918,096 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>

Reducción de consecutivos relacionados

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

Definir la función

   reducida :: (a -> a -> Bool) -> [a] -> [a]

1	reducida :: (a -> a -> Bool) -> [a] -> [a]

tal que (reducida r xs) obtenida elimando en xs las repeticiones de elementos consecutivos queverifican la relación r. Por ejemplo,

   reducida (==) [4,4,2,1,1,1,2,5]  ==  [4,2,1,2,5]
   reducida (<)  [4,4,2,1,1,1,2,5]  ==  [4,4,2,1,1,1]
   reducida (>=) [4,4,2,1,1,1,2,5]  ==  [4,5]
   reducida (>)  [4,4,2,1,1,1,2,5]  ==  [4,4,5]
   reducida (/=) [4,4,2,1,1,1,2,5]  ==  [4,4]

reducida (==) [4,4,2,1,1,1,2,5] == [4,2,1,2,5]

reducida (<) [4,4,2,1,1,1,2,5] == [4,4,2,1,1,1]

reducida (>=) [4,4,2,1,1,1,2,5] == [4,5]

reducida (>) [4,4,2,1,1,1,2,5] == [4,4,5]

reducida (/=) [4,4,2,1,1,1,2,5] == [4,4]

Soluciones

import Data.List (groupBy)

-- 1ª solución
reducida :: (a -> a -> Bool) -> [a] -> [a]
reducida _ []     = []
reducida r (x:xs) = x : reducida r (dropWhile (r x) xs)

-- 2ª solución
reducida2 :: (a -> a -> Bool) -> [a] -> [a]
reducida2 r = foldr aux []
  where aux x xs = x : dropWhile (r x) xs

-- 3ª solución
reducida3 :: (a -> a -> Bool) -> [a] -> [a]
reducida3 r xs =
  map head (groupBy r xs)

import Data.List (groupBy)

-- 1ª solución

reducida :: (a -> a -> Bool) -> [a] -> [a]

reducida _ [] = []

reducida r (x:xs) = x : reducida r (dropWhile (r x) xs)

-- 2ª solución

reducida2 :: (a -> a -> Bool) -> [a] -> [a]

reducida2 r = foldr aux []

where aux x xs = x : dropWhile (r x) xs

-- 3ª solución

reducida3 :: (a -> a -> Bool) -> [a] -> [a]

reducida3 r xs =

map head (groupBy r 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>

Lista muy decreciente

PorJosé A. Alonso 31-marzo-20217-abril-2021

Una lista de números es muy decreciente si cada elemento es mayor que la suma de los restantes. Por ejemplo, [19,9,6,2] es muy decreciente ya que

19 > 9 + 6 + 2,
9 > 6 + 2 y
6 > 2

En cambio, [19,8,6,2] no lo es ya que 8 = 6 + 2.

Definir la función

   muyDecreciente :: [Integer] -> Bool

1	muyDecreciente :: [Integer] -> Bool

tal que (muyDecreciente xs) se verifica si xs es muy decreciente. Por ejemplo,

   muyDecreciente [19,9,6,2]  ==  True
   muyDecreciente [19,8,6,2]  ==  False
   muyDecreciente [2^k | k <- [60000,59999..0]]  ==  True

muyDecreciente [19,9,6,2] == True

muyDecreciente [19,8,6,2] == False

muyDecreciente [2^k | k <- [60000,59999..0]] == True

Soluciones

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

muyDecreciente :: [Integer] -> Bool
muyDecreciente []     = True
muyDecreciente (x:xs) = x > sum xs && muyDecreciente xs

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

muyDecreciente2 :: [Integer] -> Bool
muyDecreciente2 = snd . aux
  where aux []     = (0,True)
        aux (x:xs) = (x + s, x > s && b)
          where (s,b) = aux xs

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

muyDecreciente3 :: [Integer] -> Bool
muyDecreciente3 xs =
  and (zipWith (>) xs (tail (scanr1 (+) xs)))

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

-- La comparación es
--    λ> muyDecreciente [2^k | k <- [10000,9999..0]]
--    True
--    (6.72 secs, 48,095,728,720 bytes)
--    λ> muyDecreciente2 [2^k | k <- [10000,9999..0]]
--    True
--    (0.08 secs, 67,222,960 bytes)
--    λ> muyDecreciente3 [2^k | k <- [10000,9999..0]]
--    True
--    (0.10 secs, 66,664,928 bytes)
--
--    λ> muyDecreciente2 [2^k | k <- [50000,49999..0]]
--    True
--    (1.88 secs, 857,128,312 bytes)
--    λ> muyDecreciente3 [2^k | k <- [50000,49999..0]]
--    True
--    (1.67 secs, 854,326,736 bytes)

-- 1ª solución

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

muyDecreciente :: [Integer] -> Bool

muyDecreciente [] = True

muyDecreciente (x:xs) = x > sum xs && muyDecreciente xs

-- 2ª solución

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

muyDecreciente2 :: [Integer] -> Bool

muyDecreciente2 = snd . aux

where aux [] = (0,True)

aux (x:xs) = (x + s, x > s && b)

where (s,b) = aux xs

-- 3ª solución

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

muyDecreciente3 :: [Integer] -> Bool

muyDecreciente3 xs =

and (zipWith (>) xs (tail (scanr1 (+) xs)))

-- Comparación de eficiencia

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

-- La comparación es

-- λ> muyDecreciente [2^k | k <- [10000,9999..0]]

-- True

-- (6.72 secs, 48,095,728,720 bytes)

-- λ> muyDecreciente2 [2^k | k <- [10000,9999..0]]

-- True

-- (0.08 secs, 67,222,960 bytes)

-- λ> muyDecreciente3 [2^k | k <- [10000,9999..0]]

-- True

-- (0.10 secs, 66,664,928 bytes)

-- λ> muyDecreciente2 [2^k | k <- [50000,49999..0]]

-- True

-- (1.88 secs, 857,128,312 bytes)

-- λ> muyDecreciente3 [2^k | k <- [50000,49999..0]]

-- True

-- (1.67 secs, 854,326,736 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>

Menor prefijo con suma positiva

PorJosé A. Alonso 30-marzo-20216-abril-2021

Definir la función

   menorPrefijoSumaPositiva1 :: [[Int]] -> Maybe [[Int]]

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

tal que (menorPrefijoSumaPositiva1 xss) es justamente el menor prejijo de xss tal que la suma de lsas sumas de sus elementos es positivo y es Nothing si tal prefijo no existe. Por ejemplo,

   menorPrefijoSumaPositiva [[1],[-3],[2,4]]     == Just [[1]]
   menorPrefijoSumaPositiva [[-2,1],[-3],[2,4]]  == Just [[-2,1],[-3],[2,4]]
   menorPrefijoSumaPositiva [[-2,1],[3],[2,4]]   == Just [[-2,1],[3]]
   menorPrefijoSumaPositiva [[-2,1],[-3],[2,-4]] == Nothing
   menorPrefijoSumaPositiva [[-k..k] | k <- [1..5000]]              == Nothing
   fmap length (menorPrefijoSumaPositiva [[-3000..k] | k <- [0..]]) == Just 5198

menorPrefijoSumaPositiva [[1],[-3],[2,4]] == Just [[1]]

menorPrefijoSumaPositiva [[-2,1],[-3],[2,4]] == Just [[-2,1],[-3],[2,4]]

menorPrefijoSumaPositiva [[-2,1],[3],[2,4]] == Just [[-2,1],[3]]

menorPrefijoSumaPositiva [[-2,1],[-3],[2,-4]] == Nothing

menorPrefijoSumaPositiva [[-k..k] | k <- [1..5000]] == Nothing

fmap length (menorPrefijoSumaPositiva [[-3000..k] | k <- [0..]]) == Just 5198

Soluciones

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

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

menorPrefijoSumaPositiva1 :: [[Int]] -> Maybe [[Int]]
menorPrefijoSumaPositiva1 xss =
  listToMaybe [xs | xs <- tail (inits xss),
                    sum (concat xs) > 0]

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

menorPrefijoSumaPositiva2 :: [[Int]] -> Maybe [[Int]]
menorPrefijoSumaPositiva2 xss = aux [] xss
  where aux yss _  | sum (concat yss) > 0 = Just (reverse yss)
        aux _   []                        = Nothing
        aux yss (zs:zss)                  = aux (zs : yss) zss

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

menorPrefijoSumaPositiva3 :: [[Int]] -> Maybe [[Int]]
menorPrefijoSumaPositiva3 xss =
  aux (0,[]) (zip (map sum xss) xss)
  where aux (s,yss) _  | s > 0   = Just (reverse yss)
        aux _ []                 = Nothing
        aux (s,yss) ((t,zs):zss) = aux (s+t,zs:yss) zss

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

-- La propiedad es
prop_equivalencia :: [[Int]] -> Bool
prop_equivalencia xss =
  all (== (menorPrefijoSumaPositiva1 xss))
      [ menorPrefijoSumaPositiva2 xss,
        menorPrefijoSumaPositiva3 xss ]

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

-- Comparación de eficiencia
-- =========================
--
-- La comparación es
--    λ> fmap length (menorPrefijoSumaPositiva1 [[-200..k] | k <- [0..]])
--    Just 348
--    (2.40 secs, 2,801,967,392 bytes)
--    λ> fmap length (menorPrefijoSumaPositiva2 [[-200..k] | k <- [0..]])
--    Just 348
--    (2.46 secs, 2,800,717,720 bytes)
--    λ> fmap length (menorPrefijoSumaPositiva3 [[-200..k] | k <- [0..]])
--    Just 348
--    (0.01 secs, 18,128,464 bytes)

--    λ> menorPrefijoSumaPositiva1 [[-k..k] | k <- [1..500]]
--    Nothing
--    (6.39 secs, 6,127,124,136 bytes)
--    λ> menorPrefijoSumaPositiva2 [[-k..k] | k <- [1..500]]
--    Nothing
--    (6.47 secs, 6,124,201,288 bytes)
--    λ> menorPrefijoSumaPositiva3 [[-k..k] | k <- [1..500]]
--    Nothing
--    (0.03 secs, 37,944,760 bytes)

import Data.List (inits)

import Data.Maybe (listToMaybe)

import Test.QuickCheck

-- 1ª solución

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

menorPrefijoSumaPositiva1 :: [[Int]] -> Maybe [[Int]]

menorPrefijoSumaPositiva1 xss =

listToMaybe [xs | xs <- tail (inits xss),

sum (concat xs) > 0]

-- 2ª solución

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

menorPrefijoSumaPositiva2 :: [[Int]] -> Maybe [[Int]]

menorPrefijoSumaPositiva2 xss = aux [] xss

where aux yss _ | sum (concat yss) > 0 = Just (reverse yss)

aux _ [] = Nothing

aux yss (zs:zss) = aux (zs : yss) zss

-- 3ª solución

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

menorPrefijoSumaPositiva3 :: [[Int]] -> Maybe [[Int]]

menorPrefijoSumaPositiva3 xss =

aux (0,[]) (zip (map sum xss) xss)

where aux (s,yss) _ | s > 0 = Just (reverse yss)

aux _ [] = Nothing

aux (s,yss) ((t,zs):zss) = aux (s+t,zs:yss) zss

-- Comprobación de equivalencia

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

-- La propiedad es

prop_equivalencia :: [[Int]] -> Bool

prop_equivalencia xss =

all (== (menorPrefijoSumaPositiva1 xss))

[ menorPrefijoSumaPositiva2 xss,

menorPrefijoSumaPositiva3 xss ]

-- La comprobación es

-- λ> quickCheck prop_equivalencia

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> fmap length (menorPrefijoSumaPositiva1 [[-200..k] | k <- [0..]])

-- Just 348

-- (2.40 secs, 2,801,967,392 bytes)

-- λ> fmap length (menorPrefijoSumaPositiva2 [[-200..k] | k <- [0..]])

-- Just 348

-- (2.46 secs, 2,800,717,720 bytes)

-- λ> fmap length (menorPrefijoSumaPositiva3 [[-200..k] | k <- [0..]])

-- Just 348

-- (0.01 secs, 18,128,464 bytes)

-- λ> menorPrefijoSumaPositiva1 [[-k..k] | k <- [1..500]]

-- Nothing

-- (6.39 secs, 6,127,124,136 bytes)

-- λ> menorPrefijoSumaPositiva2 [[-k..k] | k <- [1..500]]

-- Nothing

-- (6.47 secs, 6,124,201,288 bytes)

-- λ> menorPrefijoSumaPositiva3 [[-k..k] | k <- [1..500]]

-- Nothing

-- (0.03 secs, 37,944,760 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>

Autonúmeros

PorJosé A. Alonso 29-marzo-20215-abril-2021

Un autonúmero es un número entero n tal que no existe ningún número entero positivo k tal que n sea igual a la suma de k y los dígitos de k. Por ejemplo, 5 es un autonúmero pero 21 no lo es ya que 21=15+1+5.

Definir la lista

   autonumeros :: [Integer]

1	autonumeros :: [Integer]

cuyos elementos son los autonúmeros. Por ejemplo,

   λ> take 20 autonumeros
   [1,3,5,7,9,20,31,42,53,64,75,86,97,108,110,121,132,143,154,165]
   λ> autonumeros !! 1200
   12236

λ> take 20 autonumeros

[1,3,5,7,9,20,31,42,53,64,75,86,97,108,110,121,132,143,154,165]

λ> autonumeros !! 1200

12236

Soluciones

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

autonumeros :: [Integer]
autonumeros = filter autonumero [1..]

-- (autonumero n) se verifica si n es un autonúmero. Por ejemplo,
--    autonumero 5  == True
--    autonumero 21 == False
autonumero :: Integer -> Bool
autonumero n =
  all (/=n) [k + sum (digitos k) | k <- [1..n]]

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

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

autonumeros2 :: [Integer]
autonumeros2 = map head sucesionSucesionesSumasDigitales

-- sucesionSucesionesSumasDigitales es la lista de las sucesiones de
-- sumas parciales tal que el primer elemento de cada sucesión es el
-- menor elemento que no pertenece a las sucesiones anteriores. Por
-- ejemplo,
--    λ> map (take 4) (take 8 sucesionSucesionesSumasDigitales)
--    [[1,2,4,8],[3,6,12,15],[5,10,11,13],[7,14,19,29],
--     [9,18,27,36],[20,22,26,34],[31,35,43,50],[42,48,60,66]]
sucesionSucesionesSumasDigitales :: [[Integer]]
sucesionSucesionesSumasDigitales = aux [1..]
  where aux xs = sucesion xs : aux (diferencia xs (sucesion xs))
        sucesion xs = sucesionSumasDigitales (head xs)

-- (diferencia xs ys) es la diferencia las listas infinitas ordenadas
-- crecientes xs e ys. Por ejemplo,
--    λ> take 8 (diferencia [1..] [2,4..])
--    [1,3,5,7,9,11,13,15]
diferencia :: [Integer] -> [Integer] -> [Integer]
diferencia (x:xs) (y:ys)
  | x == y    = diferencia xs ys
  | otherwise = x : diferencia xs (y:ys)

-- (sucesionSumasDigitales a) es la sucesión de las sumas digitales
-- definida por un número a. Por ejemplo,
--    λ> take 16 (sucesionSumasDigitales 1)
--    [1,2,4,8,16,23,28,38,49,62,70,77,91,101,103,107]
--    λ> take 16 (sucesionSumasDigitales 3)
--    [3,6,12,15,21,24,30,33,39,51,57,69,84,96,111,114]
--    λ> take 16 (sucesionSumasDigitales 5)
--    [5,10,11,13,17,25,32,37,47,58,71,79,95,109,119,130]
--    λ> take 16 (sucesionSumasDigitales 7)
--    [7,14,19,29,40,44,52,59,73,83,94,107,115,122,127,137]
--    λ> take 16 (sucesionSumasDigitales 9)
--    [9,18,27,36,45,54,63,72,81,90,99,117,126,135,144,153]
--    λ> take 16 (sucesionSumasDigitales 20)
--    [20,22,26,34,41,46,56,67,80,88,104,109,119,130,134,142]
sucesionSumasDigitales :: Integer -> [Integer]
sucesionSumasDigitales a =
  iterate siguienteSumaDigital a

-- (siguienteSumaDigital a) es el siguiente de a en la sucesión de sumas
-- digitales. Por ejemplo,
--    siguienteSumaDigital 23 == 28
siguienteSumaDigital :: Integer -> Integer
siguienteSumaDigital a =
  a + sum (digitos a)

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

-- La comparación es
--    λ> autonumeros !! 150
--    1502
--    (4.54 secs, 13,302,379,936 bytes)
--    λ> autonumeros2 !! 150
--    1502
--    (0.06 secs, 41,794,872 bytes)

-- 1ª solución

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

autonumeros :: [Integer]

autonumeros = filter autonumero [1..]

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

-- autonumero 5 == True

-- autonumero 21 == False

autonumero :: Integer -> Bool

autonumero n =

all (/=n) [k + sum (digitos k) | k <- [1..n]]

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

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

digitos :: Integer -> [Integer]

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

-- 2ª solución

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

autonumeros2 :: [Integer]

autonumeros2 = map head sucesionSucesionesSumasDigitales

-- sucesionSucesionesSumasDigitales es la lista de las sucesiones de

-- sumas parciales tal que el primer elemento de cada sucesión es el

-- menor elemento que no pertenece a las sucesiones anteriores. Por

-- ejemplo,

-- λ> map (take 4) (take 8 sucesionSucesionesSumasDigitales)

-- [[1,2,4,8],[3,6,12,15],[5,10,11,13],[7,14,19,29],

-- [9,18,27,36],[20,22,26,34],[31,35,43,50],[42,48,60,66]]

sucesionSucesionesSumasDigitales :: [[Integer]]

sucesionSucesionesSumasDigitales = aux [1..]

where aux xs = sucesion xs : aux (diferencia xs (sucesion xs))

sucesion xs = sucesionSumasDigitales (head xs)

-- (diferencia xs ys) es la diferencia las listas infinitas ordenadas

-- crecientes xs e ys. Por ejemplo,

-- λ> take 8 (diferencia [1..] [2,4..])

-- [1,3,5,7,9,11,13,15]

diferencia :: [Integer] -> [Integer] -> [Integer]

diferencia (x:xs) (y:ys)

| x == y = diferencia xs ys

| otherwise = x : diferencia xs (y:ys)

-- (sucesionSumasDigitales a) es la sucesión de las sumas digitales

-- definida por un número a. Por ejemplo,

-- λ> take 16 (sucesionSumasDigitales 1)

-- [1,2,4,8,16,23,28,38,49,62,70,77,91,101,103,107]

-- λ> take 16 (sucesionSumasDigitales 3)

-- [3,6,12,15,21,24,30,33,39,51,57,69,84,96,111,114]

-- λ> take 16 (sucesionSumasDigitales 5)

-- [5,10,11,13,17,25,32,37,47,58,71,79,95,109,119,130]

-- λ> take 16 (sucesionSumasDigitales 7)

-- [7,14,19,29,40,44,52,59,73,83,94,107,115,122,127,137]

-- λ> take 16 (sucesionSumasDigitales 9)

-- [9,18,27,36,45,54,63,72,81,90,99,117,126,135,144,153]

-- λ> take 16 (sucesionSumasDigitales 20)

-- [20,22,26,34,41,46,56,67,80,88,104,109,119,130,134,142]

sucesionSumasDigitales :: Integer -> [Integer]

sucesionSumasDigitales a =

iterate siguienteSumaDigital a

-- (siguienteSumaDigital a) es el siguiente de a en la sucesión de sumas

-- digitales. Por ejemplo,

-- siguienteSumaDigital 23 == 28

siguienteSumaDigital :: Integer -> Integer

siguienteSumaDigital a =

a + sum (digitos a)

-- Comparación de eficiencia

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

-- La comparación es

-- λ> autonumeros !! 150

-- 1502

-- (4.54 secs, 13,302,379,936 bytes)

-- λ> autonumeros2 !! 150

-- 1502

-- (0.06 secs, 41,794,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>

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>

Sucesiones de sumas digitales

PorJosé A. Alonso 26-marzo-20212-abril-2021

La sucesión de las sumas digitales definida por un número a es sucesión a(n) tal que a(0) = a y a(n+1) es la suma de a(n) y los dígitos de a(n). Por ejemplo, los primeros términos de la sucesión de las sumas digitales definida por 1 son

   1,2,4,8,16,23,28,38,49,62,70,77,91,101,103,107,...

1	1,2,4,8,16,23,28,38,49,62,70,77,91,101,103,107,...

Se observa que el menor número que no pertenece a la sucesión anterior es 3. Los primeros términos de la sucesión de las sumas digitales definida por 3 son

   3,6,12,15,21,24,30,33,39,51,57,69,84,96,111,114,...

1	3,6,12,15,21,24,30,33,39,51,57,69,84,96,111,114,...

Se observa que el menor número que no pertenece a las 2 anteriores es 5. Los primeros términos de la sucesión de las sumas digitales definida por 5 son

   5,10,11,13,17,25,32,37,47,58,71,79,95,109,119,130,...

1	5,10,11,13,17,25,32,37,47,58,71,79,95,109,119,130,...

Se observa que el menor número que no pertenece a las 3 sucesiones anteriores es 7. Los primeros términos de la sucesión de las sumas digitales definida por 7 son

   7,14,19,29,40,44,52,59,73,83,94,107,115,122,127,137,...

1	7,14,19,29,40,44,52,59,73,83,94,107,115,122,127,137,...

Se observa que el menor número que no pertenece a las 4 anteriores es 9. Los primeros términos de la sucesión de las sumas digitales definida por 9 son

   9,18,27,36,45,54,63,72,81,90,99,117,126,135,144,153,...

1	9,18,27,36,45,54,63,72,81,90,99,117,126,135,144,153,...

Se observa que el menor número que no pertenece a las 5 sucesiones anteriores es 20. Los primeros términos de la sucesión de las sumas digitales definida por 20 son

   20,22,26,34,41,46,56,67,80,88,104,109,119,130,134,142,...

1	20,22,26,34,41,46,56,67,80,88,104,109,119,130,134,142,...

Definir la función

   sucesionSucesionesSumasDigitales :: [[Integer]]

1	sucesionSucesionesSumasDigitales :: [[Integer]]

tal que sus elementos son las sucesiones de sumas parciales tal que el primer elemento de cada sucesión es el menor elemento que no pertenece a las sucesiones anteriores. Por ejemplo,

   λ> map (take 4) (take 8 sucesionSucesionesSumasDigitales)
   [[1,2,4,8],[3,6,12,15],[5,10,11,13],[7,14,19,29],
    [9,18,27,36],[20,22,26,34],[31,35,43,50],[42,48,60,66]]
   λ> take 10 (sucesionSucesionesSumasDigitales3 !! 1000)
   [10199,10219,10232,10240,10247,10261,10271,10282,10295,10312]

λ> map (take 4) (take 8 sucesionSucesionesSumasDigitales)

[[1,2,4,8],[3,6,12,15],[5,10,11,13],[7,14,19,29],

[9,18,27,36],[20,22,26,34],[31,35,43,50],[42,48,60,66]]

λ> take 10 (sucesionSucesionesSumasDigitales3 !! 1000)

[10199,10219,10232,10240,10247,10261,10271,10282,10295,10312]

Soluciones

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

sucesionSucesionesSumasDigitales :: [[Integer]]
sucesionSucesionesSumasDigitales =
  map aux [1..]
  where aux 1 = sucesionSumasDigitales 1
        aux n = sucesionSumasDigitales m
          where m = head [a | a <- [1..],
                              all (a `noPertenece`)
                                  [aux k | k <- [1..n-1]]]

-- (sucesionSumasDigitales a) es la sucesión de las sumas digitales
-- definida por un número a. Por ejemplo,
--    λ> take 16 (sucesionSumasDigitales 1)
--    [1,2,4,8,16,23,28,38,49,62,70,77,91,101,103,107]
--    λ> take 16 (sucesionSumasDigitales 3)
--    [3,6,12,15,21,24,30,33,39,51,57,69,84,96,111,114]
--    λ> take 16 (sucesionSumasDigitales 5)
--    [5,10,11,13,17,25,32,37,47,58,71,79,95,109,119,130]
--    λ> take 16 (sucesionSumasDigitales 7)
--    [7,14,19,29,40,44,52,59,73,83,94,107,115,122,127,137]
--    λ> take 16 (sucesionSumasDigitales 9)
--    [9,18,27,36,45,54,63,72,81,90,99,117,126,135,144,153]
--    λ> take 16 (sucesionSumasDigitales 20)
--    [20,22,26,34,41,46,56,67,80,88,104,109,119,130,134,142]
sucesionSumasDigitales :: Integer -> [Integer]
sucesionSumasDigitales a =
  iterate siguienteSumaDigital a

-- (siguienteSumaDigital a) es el siguiente de a en la sucesión de sumas
-- digitales. Por ejemplo,
--    siguienteSumaDigital 23 == 28
siguienteSumaDigital :: Integer -> Integer
siguienteSumaDigital a =
  a + sum (digitos a)

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

-- (noPertenece x ys) se verifica si x no pertenece a la lista infinita
-- ordenada creciente ys. Por ejemplo,
--    noPertenece 2 [1,3..] == True
--    noPertenece 5 [1,3..] == False
noPertenece :: Integer -> [Integer] -> Bool
noPertenece x ys =
  x < head (dropWhile (<x) ys)

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

sucesionSucesionesSumasDigitales2 :: [[Integer]]
sucesionSucesionesSumasDigitales2 =
  map sucesionSumasDigitales autonumeros

-- (autonumero n) se verifica si n es un autonúmero; es decir, números
-- que no se pueden escribir como la suma de un número k y los dígitos
-- de k. Por ejemplo,
--    autonumero 5  == True
--    autonumero 21 == False
autonumero :: Integer -> Bool
autonumero n =
  all (/=n) [k + sum (digitos k) | k <- [1..n]]

-- autonumeros es la lista de los autonúmeros. Por ejemplo,
--    λ> take 20 autonumeros
--    [1,3,5,7,9,20,31,42,53,64,75,86,97,108,110,121,132,143,154,165]
autonumeros :: [Integer]
autonumeros = filter autonumero [1..]

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

sucesionSucesionesSumasDigitales3 :: [[Integer]]
sucesionSucesionesSumasDigitales3 = aux [1..]
  where aux xs = sucesion xs : aux (diferencia xs (sucesion xs))
        sucesion xs = sucesionSumasDigitales (head xs)

-- (diferencia xs ys) es la diferencia las listas infinitas ordenadas
-- crecientes xs e ys. Por ejemplo,
--    λ> take 8 (diferencia [1..] [2,4..])
--    [1,3,5,7,9,11,13,15]
diferencia :: [Integer] -> [Integer] -> [Integer]
diferencia (x:xs) (y:ys)
  | x == y    = diferencia xs ys
  | otherwise = x : diferencia xs (y:ys)

-- 1ª solución

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

sucesionSucesionesSumasDigitales :: [[Integer]]

sucesionSucesionesSumasDigitales =

map aux [1..]

where aux 1 = sucesionSumasDigitales 1

aux n = sucesionSumasDigitales m

where m = head [a | a <- [1..],

all (a `noPertenece`)

[aux k | k <- [1..n-1]]]

-- (sucesionSumasDigitales a) es la sucesión de las sumas digitales

-- definida por un número a. Por ejemplo,

-- λ> take 16 (sucesionSumasDigitales 1)

-- [1,2,4,8,16,23,28,38,49,62,70,77,91,101,103,107]

-- λ> take 16 (sucesionSumasDigitales 3)

-- [3,6,12,15,21,24,30,33,39,51,57,69,84,96,111,114]

-- λ> take 16 (sucesionSumasDigitales 5)

-- [5,10,11,13,17,25,32,37,47,58,71,79,95,109,119,130]

-- λ> take 16 (sucesionSumasDigitales 7)

-- [7,14,19,29,40,44,52,59,73,83,94,107,115,122,127,137]

-- λ> take 16 (sucesionSumasDigitales 9)

-- [9,18,27,36,45,54,63,72,81,90,99,117,126,135,144,153]

-- λ> take 16 (sucesionSumasDigitales 20)

-- [20,22,26,34,41,46,56,67,80,88,104,109,119,130,134,142]

sucesionSumasDigitales :: Integer -> [Integer]

sucesionSumasDigitales a =

iterate siguienteSumaDigital a

-- (siguienteSumaDigital a) es el siguiente de a en la sucesión de sumas

-- digitales. Por ejemplo,

-- siguienteSumaDigital 23 == 28

siguienteSumaDigital :: Integer -> Integer

siguienteSumaDigital a =

a + sum (digitos a)

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

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

digitos :: Integer -> [Integer]

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

-- (noPertenece x ys) se verifica si x no pertenece a la lista infinita

-- ordenada creciente ys. Por ejemplo,

-- noPertenece 2 [1,3..] == True

-- noPertenece 5 [1,3..] == False

noPertenece :: Integer -> [Integer] -> Bool

noPertenece x ys =

x < head (dropWhile (<x) ys)

-- 2ª solución

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

sucesionSucesionesSumasDigitales2 :: [[Integer]]

sucesionSucesionesSumasDigitales2 =

map sucesionSumasDigitales autonumeros

-- (autonumero n) se verifica si n es un autonúmero; es decir, números

-- que no se pueden escribir como la suma de un número k y los dígitos

-- de k. Por ejemplo,

-- autonumero 5 == True

-- autonumero 21 == False

autonumero :: Integer -> Bool

autonumero n =

all (/=n) [k + sum (digitos k) | k <- [1..n]]

-- autonumeros es la lista de los autonúmeros. Por ejemplo,

-- λ> take 20 autonumeros

-- [1,3,5,7,9,20,31,42,53,64,75,86,97,108,110,121,132,143,154,165]

autonumeros :: [Integer]

autonumeros = filter autonumero [1..]

-- 3ª solución

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

sucesionSucesionesSumasDigitales3 :: [[Integer]]

sucesionSucesionesSumasDigitales3 = aux [1..]

where aux xs = sucesion xs : aux (diferencia xs (sucesion xs))

sucesion xs = sucesionSumasDigitales (head xs)

-- (diferencia xs ys) es la diferencia las listas infinitas ordenadas

-- crecientes xs e ys. Por ejemplo,

-- λ> take 8 (diferencia [1..] [2,4..])

-- [1,3,5,7,9,11,13,15]

diferencia :: [Integer] -> [Integer] -> [Integer]

diferencia (x:xs) (y:ys)

| x == y = diferencia xs ys

| otherwise = x : diferencia xs (y:ys)

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>

Coste del recorrido ordenado

PorJosé A. Alonso 25-marzo-20211-abril-2021

El coste de visitar los elementos de la lista [4,3,2,5,1] de manera creciente empezando en el primer elemento y siendo el coste de dada paso el valor absoluto de la diferencia de las posiciones se calcula de la siguiente manera

Coste de 4 a 1 = |0-4| = 4
Coste de 1 a 2 = |4-2| = 2
Coste de 2 a 3 = |2-1| = 1
Coste de 3 a 4 = |1-0| = 1
Coste de 4 a 5 = |0-3| = 3

Por tanto, el coste del recorrido es 4+2+1+1+3 = 11.

Definir la función coste :: Ord a => [a] -> Int tal que (coste xs) es el coste de visitar los elementos de xs de manera creciente empezando en el primer elemento y siendo el coste de dada paso el valor absoluto de la diferencia de las posiciones (se supone que los elementos de xs son distintos). Por ejemplo,

   coste [4,3,2,5,1] ==  11
   coste "betis"     ==  6

1 2	coste [4,3,2,5,1] == 11 coste "betis" == 6

Soluciones

import Data.List (sort)

coste :: Ord  a => [a] -> Int
coste xs =
  sum [abs (i-j) | (i,j) <- zip aux (tail aux)]
  where aux = recorrido xs

-- (recorrido xs) esla lista de las posiciones al visitar los elementos
-- de xs de manera creciente empezando en el primer elemento. Por
-- ejemplo,
--    recorrido [4,3,2,5,1] == [0,4,2,1,0,3]
recorrido :: Ord  a => [a] -> [Int]
recorrido xs =
  0 : map snd (sort (zip xs [0..]))

import Data.List (sort)

coste :: Ord a => [a] -> Int

coste xs =

sum [abs (i-j) | (i,j) <- zip aux (tail aux)]

where aux = recorrido xs

-- (recorrido xs) esla lista de las posiciones al visitar los elementos

-- de xs de manera creciente empezando en el primer elemento. Por

-- ejemplo,

-- recorrido [4,3,2,5,1] == [0,4,2,1,0,3]

recorrido :: Ord a => [a] -> [Int]

recorrido xs =

0 : map snd (sort (zip xs [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ínimo número de divisiones para igualar

PorJosé A. Alonso 24-marzo-202131-marzo-2021

El mínimo número de divisiones por 2, 3 ó 5 que hay que realizar igualar 15 y 20 es 6. En efecto, 15 se reduce a 5 dividiéndolo por 3 y 20 se reduce a 5 diviéndolo dos veces por 2.

Definir la función

   minimoNumeroDivisiones :: Integer -> Integer -> Maybe Int

1	minimoNumeroDivisiones :: Integer -> Integer -> Maybe Int

tal que (minimoNumeroDivisiones x y) es justamente el mínimo número de divisiones por 2, 3 ó 5 que hay que realizar para igualar x e y, o Nothing si no se pueden igualar. Por ejemplo,

   minimoNumeroDivisiones 15 20       ==  Just 3
   minimoNumeroDivisiones 15 15       ==  Just 0
   minimoNumeroDivisiones 15 16       ==  Just 6
   minimoNumeroDivisiones 15 17       ==  Nothing
   minimoNumeroDivisiones (10^99) 21  ==  Nothing

minimoNumeroDivisiones 15 20 == Just 3

minimoNumeroDivisiones 15 15 == Just 0

minimoNumeroDivisiones 15 16 == Just 6

minimoNumeroDivisiones 15 17 == Nothing

minimoNumeroDivisiones (10^99) 21 == Nothing

Soluciones

import Data.List (group, intersect, nub, sort)
import Data.Maybe (fromJust, isNothing, listToMaybe)
import Data.Numbers.Primes (primeFactors)
import Data.Tree (Tree (Node), flatten, levels)
import Test.QuickCheck (Property, (==>), quickCheck)

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

minimoNumeroDivisiones :: Integer -> Integer -> Maybe Int
minimoNumeroDivisiones x y
  | isNothing a = Nothing
  | otherwise   = Just (fst (fromJust a))
  where a = minimoNumeroDivisionesAux x y

-- La definición anterior se puede simplificar
minimoNumeroDivisiones' :: Integer -> Integer -> Maybe Int
minimoNumeroDivisiones' x y =
  Just fst <*> minimoNumeroDivisionesAux x y

-- (minimoNumeroDivisiones x y) es justamente el par formado por el
-- mínimo número de divisiones por 2, 3 ó 5 que hay que realizar para
-- igualar x e y junto con el número al que se reducen, o Nothing si no
-- se pueden igualar. Por ejemplo,
--    minimoNumeroDivisionesAux 15 20  ==  Just (3,5)
--    minimoNumeroDivisionesAux 15 15  ==  Just (0,15)
--    minimoNumeroDivisionesAux 15 16  ==  Just (6,1)
--    minimoNumeroDivisionesAux 15 17  ==  Nothing
minimoNumeroDivisionesAux :: Integer -> Integer -> Maybe (Int,Integer)
minimoNumeroDivisionesAux x y
  | null as   = Nothing
  | otherwise = Just (head as)
  where as = sort [(m+n,z) | (z,(m,n)) <- minimasProfundidadesComunes x y]

-- La definición anterior se puede simplificar
minimoNumeroDivisionesAux2 :: Integer -> Integer -> Maybe (Int,Integer)
minimoNumeroDivisionesAux2 x y =
  listToMaybe (sort [(m+n,z) | (z,(m,n)) <- minimasProfundidadesComunes x y])

-- (arbolDivisiones x) es el árbol de las divisiones enteras de x entre
-- 2, 3 ó 5. Por ejemplo,
--    λ> putStrLn (drawTree (fmap show (arbolDivisiones 30)))
--    30
--    |
--    +- 15
--    |  |
--    |  +- 5
--    |  |  |
--    |  |  `- 1
--    |  |
--    |  `- 3
--    |     |
--    |     `- 1
--    |
--    +- 10
--    |  |
--    |  +- 5
--    |  |  |
--    |  |  `- 1
--    |  |
--    |  `- 2
--    |     |
--    |     `- 1
--    |
--    `- 6
--       |
--       +- 3
--       |  |
--       |  `- 1
--       |
--       `- 2
--          |
--          `- 1
arbolDivisiones :: Integer -> Tree Integer
arbolDivisiones x =
  Node x (map arbolDivisiones (divisiones x))

-- (divisiones x) es la lista de las divisiones enteras de x entre 2, 3
-- y 5. Por ejemplo,
--    divisiones 30  ==  [15,10,6]
--    divisiones 15  ==  [5,3]
divisiones :: Integer -> [Integer]
divisiones x =
  [x `div` y | y <- [2,3,5], x `mod` y == 0]

-- (nodos a) es el conjunto de nodos del árbol a. Por ejemplo,
--    nodos (Node 2 [Node 2 [], Node 5 []])  ==  [2,5]
--    nodos (arbolDivisiones 30)  ==  [30,15,5,1,3,10,2,6]
nodos :: Tree Integer -> [Integer]
nodos = nub . flatten

-- (divisionesComunes x y) es la lista de los nodos comunes de los
-- árboles de las divisiones de x e y entre 2, 3 ó 5. Por ejemplo,
--    divisionesComunes 15 20  ==  [5,1]
divisionesComunes :: Integer -> Integer -> [Integer]
divisionesComunes x y =
  nodos (arbolDivisiones x) `intersect` nodos (arbolDivisiones y)

-- (minimaProfundidad x ns) es justamente la mínima produndidad
-- donde aparece x en el árbol ns, si aparece y Nothing, en caso
-- contrario. Por ejemplo,minimaProfundidad :: Ord a => a -> Tree a -> Maybe Int
--    λ> minimaProfundidad 3 (Node 1 [Node 6 [],Node 3 [Node 1 []]])
--    Just 1
--    λ> minimaProfundidad 4 (Node 1 [Node 6 [],Node 3 [Node 1 []]])
--    Nothing
minimaProfundidad :: Ord a => a -> Tree a -> Maybe Int
minimaProfundidad x ns =
  listToMaybe [z | (z,ys) <- zip [0..] (levels ns), x `elem` ys]

-- (minimasProfundidadesComunes x e y) es la lista de pares formadas por
-- los nodos comunes de los árboles de las divisiones de x e y entre 2,
-- 3 ó 5 junto con las mínimas profundidades en cada uno de los
-- árboles. Por ejemplo,
--    minimasProfundidadesComunes 15 20  ==  [(5,(1,2)),(1,(2,3))]
--    minimasProfundidadesComunes 15 22  ==  []
minimasProfundidadesComunes :: Integer -> Integer -> [(Integer,(Int,Int))]
minimasProfundidadesComunes x1 x2 =
  [(c,(fromJust (minimaProfundidad c a1), fromJust (minimaProfundidad c a2)))
  | c <- cs]
  where a1 = arbolDivisiones x1
        a2 = arbolDivisiones x2
        cs = divisionesComunes x1 x2

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

-- El mínimo número de divisiones se alcanza en el máximo común divisor.
prop_minimoNumeroDivisiones :: Integer -> Integer -> Property
prop_minimoNumeroDivisiones x y =
  x > 0 && y > 0 ==>
  isNothing a || snd (fromJust a) == gcd x y
  where a = minimoNumeroDivisionesAux x y

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

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

minimoNumeroDivisiones2 :: Integer -> Integer -> Maybe Int
minimoNumeroDivisiones2 x y
  | as' == bs' = Just (sum [abs (a - b) | (a,b) <- zip as bs])
  | otherwise  = Nothing
  where (as,as') = factorizacion x
        (bs,bs') = factorizacion y

-- (factorización n) es la lista de pares cuya primera componente es la
-- lista de los exponentes de 2, 3 y 5 en la factorización de n y la
-- segunda esla lista delos restantes divisores primos. Por ejemplo,
--    factorizacion 15   ==  ([0,1,1],[])
--    factorizacion 20   ==  ([2,0,1],[])
--    factorizacion 17   ==  ([0,0,0],[17])
--    factorizacion 147  ==  ([0,1,0],[7,7])
factorizacion :: Integer -> ([Int],[Integer])
factorizacion n =
  (map length [bs,cs,ds], es)
  where as = primeFactors n
        (bs,bs') = span (==2) as
        (cs,cs') = span (==3) bs'
        (ds,es)  = span (==5) cs'

-- Equivalencia
-- ============

-- La propies de la equivalencia de las dos definiciones es
prop_equivalencia :: Integer -> Integer -> Property
prop_equivalencia x y =
  x > 0 && y > 0 ==>
  minimoNumeroDivisiones x y == minimoNumeroDivisiones2 x y

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

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

--    λ> minimoNumeroDivisiones (10^11) (3^10*7)
--    Nothing
--    (6.08 secs, 2,725,931,872 bytes)
--    λ> minimoNumeroDivisiones2(10^11) (3^10*7)
--    Nothing
--    (0.01 secs, 128,944 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

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

182

183

184

import Data.List (group, intersect, nub, sort)

import Data.Maybe (fromJust, isNothing, listToMaybe)

import Data.Numbers.Primes (primeFactors)

import Data.Tree (Tree (Node), flatten, levels)

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

-- 1ª solución

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

minimoNumeroDivisiones :: Integer -> Integer -> Maybe Int

minimoNumeroDivisiones x y

| isNothing a = Nothing

| otherwise = Just (fst (fromJust a))

where a = minimoNumeroDivisionesAux x y

-- La definición anterior se puede simplificar

minimoNumeroDivisiones' :: Integer -> Integer -> Maybe Int

minimoNumeroDivisiones' x y =

Just fst <*> minimoNumeroDivisionesAux x y

-- (minimoNumeroDivisiones x y) es justamente el par formado por el

-- mínimo número de divisiones por 2, 3 ó 5 que hay que realizar para

-- igualar x e y junto con el número al que se reducen, o Nothing si no

-- se pueden igualar. Por ejemplo,

-- minimoNumeroDivisionesAux 15 20 == Just (3,5)

-- minimoNumeroDivisionesAux 15 15 == Just (0,15)

-- minimoNumeroDivisionesAux 15 16 == Just (6,1)

-- minimoNumeroDivisionesAux 15 17 == Nothing

minimoNumeroDivisionesAux :: Integer -> Integer -> Maybe (Int,Integer)

minimoNumeroDivisionesAux x y

| null as = Nothing

| otherwise = Just (head as)

where as = sort [(m+n,z) | (z,(m,n)) <- minimasProfundidadesComunes x y]

-- La definición anterior se puede simplificar

minimoNumeroDivisionesAux2 :: Integer -> Integer -> Maybe (Int,Integer)

minimoNumeroDivisionesAux2 x y =

listToMaybe (sort [(m+n,z) | (z,(m,n)) <- minimasProfundidadesComunes x y])

-- (arbolDivisiones x) es el árbol de las divisiones enteras de x entre

-- 2, 3 ó 5. Por ejemplo,

-- λ> putStrLn (drawTree (fmap show (arbolDivisiones 30)))

-- 30

-- |

-- +- 15

-- | |

-- | +- 5

-- | | |

-- | | `- 1

-- | |

-- | `- 3

-- | |

-- | `- 1

-- |

-- +- 10

-- | |

-- | +- 5

-- | | |

-- | | `- 1

-- | |

-- | `- 2

-- | |

-- | `- 1

-- |

-- `- 6

-- |

-- +- 3

-- | |

-- | `- 1

-- |

-- `- 2

-- |

-- `- 1

arbolDivisiones :: Integer -> Tree Integer

arbolDivisiones x =

Node x (map arbolDivisiones (divisiones x))

-- (divisiones x) es la lista de las divisiones enteras de x entre 2, 3

-- y 5. Por ejemplo,

-- divisiones 30 == [15,10,6]

-- divisiones 15 == [5,3]

divisiones :: Integer -> [Integer]

divisiones x =

[x `div` y | y <- [2,3,5], x `mod` y == 0]

-- (nodos a) es el conjunto de nodos del árbol a. Por ejemplo,

-- nodos (Node 2 [Node 2 [], Node 5 []]) == [2,5]

-- nodos (arbolDivisiones 30) == [30,15,5,1,3,10,2,6]

nodos :: Tree Integer -> [Integer]

nodos = nub . flatten

-- (divisionesComunes x y) es la lista de los nodos comunes de los

-- árboles de las divisiones de x e y entre 2, 3 ó 5. Por ejemplo,

-- divisionesComunes 15 20 == [5,1]

divisionesComunes :: Integer -> Integer -> [Integer]

divisionesComunes x y =

nodos (arbolDivisiones x) `intersect` nodos (arbolDivisiones y)

-- (minimaProfundidad x ns) es justamente la mínima produndidad

-- donde aparece x en el árbol ns, si aparece y Nothing, en caso

-- contrario. Por ejemplo,minimaProfundidad :: Ord a => a -> Tree a -> Maybe Int

-- λ> minimaProfundidad 3 (Node 1 [Node 6 [],Node 3 [Node 1 []]])

-- Just 1

-- λ> minimaProfundidad 4 (Node 1 [Node 6 [],Node 3 [Node 1 []]])

-- Nothing

minimaProfundidad :: Ord a => a -> Tree a -> Maybe Int

minimaProfundidad x ns =

listToMaybe [z | (z,ys) <- zip [0..] (levels ns), x `elem` ys]

-- (minimasProfundidadesComunes x e y) es la lista de pares formadas por

-- los nodos comunes de los árboles de las divisiones de x e y entre 2,

-- 3 ó 5 junto con las mínimas profundidades en cada uno de los

-- árboles. Por ejemplo,

-- minimasProfundidadesComunes 15 20 == [(5,(1,2)),(1,(2,3))]

-- minimasProfundidadesComunes 15 22 == []

minimasProfundidadesComunes :: Integer -> Integer -> [(Integer,(Int,Int))]

minimasProfundidadesComunes x1 x2 =

[(c,(fromJust (minimaProfundidad c a1), fromJust (minimaProfundidad c a2)))

| c <- cs]

where a1 = arbolDivisiones x1

a2 = arbolDivisiones x2

cs = divisionesComunes x1 x2

-- Propiedad

-- =========

-- El mínimo número de divisiones se alcanza en el máximo común divisor.

prop_minimoNumeroDivisiones :: Integer -> Integer -> Property

prop_minimoNumeroDivisiones x y =

x > 0 && y > 0 ==>

isNothing a || snd (fromJust a) == gcd x y

where a = minimoNumeroDivisionesAux x y

-- La comprobación es

-- λ> quickCheck prop_minimoNumeroDivisiones

-- +++ OK, passed 100 tests.

-- 2ª solución

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

minimoNumeroDivisiones2 :: Integer -> Integer -> Maybe Int

minimoNumeroDivisiones2 x y

| as' == bs' = Just (sum [abs (a - b) | (a,b) <- zip as bs])

| otherwise = Nothing

where (as,as') = factorizacion x

(bs,bs') = factorizacion y

-- (factorización n) es la lista de pares cuya primera componente es la

-- lista de los exponentes de 2, 3 y 5 en la factorización de n y la

-- segunda esla lista delos restantes divisores primos. Por ejemplo,

-- factorizacion 15 == ([0,1,1],[])

-- factorizacion 20 == ([2,0,1],[])

-- factorizacion 17 == ([0,0,0],[17])

-- factorizacion 147 == ([0,1,0],[7,7])

factorizacion :: Integer -> ([Int],[Integer])

factorizacion n =

(map length [bs,cs,ds], es)

where as = primeFactors n

(bs,bs') = span (==2) as

(cs,cs') = span (==3) bs'

(ds,es) = span (==5) cs'

-- Equivalencia

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

-- La propies de la equivalencia de las dos definiciones es

prop_equivalencia :: Integer -> Integer -> Property

prop_equivalencia x y =

x > 0 && y > 0 ==>

minimoNumeroDivisiones x y == minimoNumeroDivisiones2 x y

-- La comprobación es

-- λ> quickCheck prop_equivalencia

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- λ> minimoNumeroDivisiones (10^11) (3^10*7)

-- Nothing

-- (6.08 secs, 2,725,931,872 bytes)

-- λ> minimoNumeroDivisiones2(10^11) (3^10*7)

-- Nothing

-- (0.01 secs, 128,944 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ínima profundidad

PorJosé A. Alonso 23-marzo-202130-marzo-2021

En la librería Data.Tree se definen los árboles y los bosques como sigue

   data Tree a   = Node a (Forest a)
   type Forest a = [Tree a]

1 2	data Tree a = Node a (Forest a) type Forest a = [Tree a]

Por ejemplo, los árboles

     1               3
    / \             /|\
   6   3           / | \
       |          5  4  7
       1          |     /\
                  3    6  5

1 3

/ \ /|\

6 3 / | \

| 5 4 7

1 | /\

3 6 5

se representan por

   ej1, ej2 :: Tree Int
   ej1 = Node 1 [Node 6 [],Node 3 [Node 1 []]]
   ej2 = Node 3 [Node 5 [Node 3 []], Node 4 [], Node 7 [Node 6 [], Node 5 []]]

ej1, ej2 :: Tree Int

ej1 = Node 1 [Node 6 [],Node 3 [Node 1 []]]

ej2 = Node 3 [Node 5 [Node 3 []], Node 4 [], Node 7 [Node 6 [], Node 5 []]]

Definir la función

    minimaProfundidad :: Ord a => a -> Tree a -> Maybe Int

1	minimaProfundidad :: Ord a => a -> Tree a -> Maybe Int

tal que (minimaProfundidad x ns) es justamente la mínima donde aparece x en el árbol ns, si aparece y Nothing, en caso contrario. Por ejemplo,

    minimaProfundidad 1 ej1  ==  Just 0
    minimaProfundidad 3 ej1  ==  Just 1
    minimaProfundidad 2 ej1  ==  Nothing
    minimaProfundidad 3 ej2  ==  Just 0
    minimaProfundidad 4 ej2  ==  Just 1
    minimaProfundidad 6 ej2  ==  Just 2
    minimaProfundidad 9 ej2  ==  Nothing

minimaProfundidad 1 ej1 == Just 0

minimaProfundidad 3 ej1 == Just 1

minimaProfundidad 2 ej1 == Nothing

minimaProfundidad 3 ej2 == Just 0

minimaProfundidad 4 ej2 == Just 1

minimaProfundidad 6 ej2 == Just 2

minimaProfundidad 9 ej2 == Nothing

Soluciones

import Data.Tree (Tree (Node), levels)
import Data.Maybe (isNothing, fromJust, listToMaybe)

ej1, ej2 :: Tree Int
ej1 = Node 1 [Node 6 [],Node 3 [Node 1 []]]
ej2 = Node 3 [Node 5 [Node 3 []], Node 4 [], Node 7 [Node 6 [], Node 5 []]]

-- 1ª definición
minimaProfundidad1 :: Ord a => a -> Tree a -> Maybe Int
minimaProfundidad1 x (Node y ns)
  | x == y    = Just 0
  | null zs   = Nothing
  | otherwise = Just (1 + minimum zs)
  where zs = [z | Just z <- filter (/=Nothing) (map (minimaProfundidad1 x) ns)]

-- 2ª definición
minimaProfundidad2 :: Ord a => a -> Tree a -> Maybe Int
minimaProfundidad2 x (Node y ns)
  | x == y       = Just 0
  | z == Nothing = Nothing
  | otherwise    = Just (1 + fromJust z)
  where z = minimum (map (minimaProfundidad2 x) ns)

-- 3ª definición
minimaProfundidad3 :: Ord a => a -> Tree a -> Maybe Int
minimaProfundidad3 x (Node y ns)
  | x == y       = Just 0
  | otherwise    = Just (+1) <*> minimum (map (minimaProfundidad3 x) ns)

-- 4ª definición
minimaProfundidad4 :: Ord a => a -> Tree a -> Maybe Int
minimaProfundidad4 x ns
  | null zs   = Nothing
  | otherwise = Just (head zs)
  where zs = [z | (z,ys) <- zip [0..] (levels ns), x `elem` ys]

-- 5ª definición
minimaProfundidad5 :: Ord a => a -> Tree a -> Maybe Int
minimaProfundidad5 x ns =
  listToMaybe [z | (z,ys) <- zip [0..] (levels ns), x `elem` ys]

import Data.Tree (Tree (Node), levels)

import Data.Maybe (isNothing, fromJust, listToMaybe)

ej1, ej2 :: Tree Int

ej1 = Node 1 [Node 6 [],Node 3 [Node 1 []]]

ej2 = Node 3 [Node 5 [Node 3 []], Node 4 [], Node 7 [Node 6 [], Node 5 []]]

-- 1ª definición

minimaProfundidad1 :: Ord a => a -> Tree a -> Maybe Int

minimaProfundidad1 x (Node y ns)

| x == y = Just 0

| null zs = Nothing

| otherwise = Just (1 + minimum zs)

where zs = [z | Just z <- filter (/=Nothing) (map (minimaProfundidad1 x) ns)]

-- 2ª definición

minimaProfundidad2 :: Ord a => a -> Tree a -> Maybe Int

minimaProfundidad2 x (Node y ns)

| x == y = Just 0

| z == Nothing = Nothing

| otherwise = Just (1 + fromJust z)

where z = minimum (map (minimaProfundidad2 x) ns)

-- 3ª definición

minimaProfundidad3 :: Ord a => a -> Tree a -> Maybe Int

minimaProfundidad3 x (Node y ns)

| x == y = Just 0

| otherwise = Just (+1) <*> minimum (map (minimaProfundidad3 x) ns)

-- 4ª definición

minimaProfundidad4 :: Ord a => a -> Tree a -> Maybe Int

minimaProfundidad4 x ns

| null zs = Nothing

| otherwise = Just (head zs)

where zs = [z | (z,ys) <- zip [0..] (levels ns), x `elem` ys]

-- 5ª definición

minimaProfundidad5 :: Ord a => a -> Tree a -> Maybe Int

minimaProfundidad5 x ns =

listToMaybe [z | (z,ys) <- zip [0..] (levels ns), x `elem` ys]

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>

Suma de la lista reducida

PorJosé A. Alonso 4-marzo-202111-marzo-2021

Definir las siguientes funciones

   transformada :: Integral a => [a] -> [a]
   reducida     :: Integral a => [a] -> [a]
   sumaReducida :: Integral a => [a] -> a

transformada :: Integral a => [a] -> [a]

reducida :: Integral a => [a] -> [a]

sumaReducida :: Integral a => [a] -> a

tales que

(transformada xs) es la lista obtenida sustituyendo en el primer de elementos consecutivos de xs el mayor por su diferencia, donde se supone que xs es una lista de enteros positivos. Por ejemplo,

     transformada [7,2,6]  ==  [5,2,6]
     transformada [2,7,6]  ==  [2,5,6]
     transformada [2,2,6]  ==  [2,2,4]
     transformada [2,2,2]  ==  [2,2,2]

transformada [7,2,6] == [5,2,6]

transformada [2,7,6] == [2,5,6]

transformada [2,2,6] == [2,2,4]

transformada [2,2,2] == [2,2,2]

(reducida xs) es la lista obtenida aplicando la transformación anterior mientras sea posible (es decir, mientras tenga elementos distintos), donde se supone que xs es una lista de enteros positivos. Por ejemplo,

     reducida [7,2,6]   ==  [1,1,1]
     reducida [6,9,21]  ==  [3,3,3]

1 2	reducida [7,2,6] == [1,1,1] reducida [6,9,21] == [3,3,3]

(sumaReducida xs) es la suma de la reducida de la lista xs. Por ejemplo,

     sumaReducida1 [7,2,6]   ==  3
     sumaReducida1 [6,9,21]  ==  9

1 2	sumaReducida1 [7,2,6] == 3 sumaReducida1 [6,9,21] == 9

Soluciones

import Data.List (genericLength)

-- Definición de transformada
-- ==========================

transformada :: Integral a => [a] -> [a]
transformada []  = []
transformada [x] = [x]
transformada (x:y:zs)
  | x > y = x-y : y : zs
  | x < y = x : y-x : zs
  | otherwise = x : transformada (y:zs)

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

reducida1 :: Integral a => [a] -> [a]
reducida1 xs
  | xs == ys  = xs
  | otherwise = reducida ys
  where ys = transformada xs

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

reducida2 :: Integral a => [a] -> [a]
reducida2 xs =
  replicate (length xs) (foldl1 gcd xs)

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

-- La comparación es
--    λ> sum (reducida1 [2,4..4*10^6])
--    4000000
--    (1.97 secs, 1,277,797,888 bytes)
--    λ> sum (reducida2 [2,4..4*10^6])
--    4000000
--    (1.92 secs, 1,277,798,344 bytes)

-- Definición de reducida
-- =======================

reducida :: Integral a => [a] -> [a]
reducida = reducida2

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

sumaReducida1 :: Integral a => [a] -> a
sumaReducida1 = sum . reducida

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

sumaReducida2 :: Integral a => [a] -> a
sumaReducida2 xs = genericLength xs * foldl1 gcd xs

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

-- La comparación es
--    λ> sumaReducida1 [2,4..4*10^6]
--    4000000
--    (2.53 secs, 1,277,796,760 bytes)
--    λ> sumaReducida2 [2,4..4*10^6]
--    4000000
--    (1.89 secs, 1,214,376,960 bytes)

import Data.List (genericLength)

-- Definición de transformada

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

transformada :: Integral a => [a] -> [a]

transformada [] = []

transformada [x] = [x]

transformada (x:y:zs)

| x > y = x-y : y : zs

| x < y = x : y-x : zs

| otherwise = x : transformada (y:zs)

-- 1ª definición de reducida

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

reducida1 :: Integral a => [a] -> [a]

reducida1 xs

| xs == ys = xs

| otherwise = reducida ys

where ys = transformada xs

-- 2ª definición de reducida

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

reducida2 :: Integral a => [a] -> [a]

reducida2 xs =

replicate (length xs) (foldl1 gcd xs)

-- Comparación de eficiencia

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

-- La comparación es

-- λ> sum (reducida1 [2,4..4*10^6])

-- 4000000

-- (1.97 secs, 1,277,797,888 bytes)

-- λ> sum (reducida2 [2,4..4*10^6])

-- 4000000

-- (1.92 secs, 1,277,798,344 bytes)

-- Definición de reducida

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

reducida :: Integral a => [a] -> [a]

reducida = reducida2

-- 1ª definición de sumaReducida

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

sumaReducida1 :: Integral a => [a] -> a

sumaReducida1 = sum . reducida

-- 2ª solución

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

sumaReducida2 :: Integral a => [a] -> a

sumaReducida2 xs = genericLength xs * foldl1 gcd xs

-- Comparación de eficiencia

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

-- La comparación es

-- λ> sumaReducida1 [2,4..4*10^6]

-- 4000000

-- (2.53 secs, 1,277,796,760 bytes)

-- λ> sumaReducida2 [2,4..4*10^6]

-- 4000000

-- (1.89 secs, 1,214,376,960 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>

Eliminaciones anotadas

PorJosé A. Alonso 26-febrero-20215-marzo-2021

Definir la función

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

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

tal que (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])]

1 2	λ> 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])]

Soluciones

import Test.QuickCheck (quickCheck)

-- 1ª solución
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
eliminaciones2 :: [a] -> [(a,Int,[a])]
eliminaciones2 xs =
  [(v,i,us++vs) | i <- [0..length xs - 1],
                  let (us,v:vs) = splitAt i xs]

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

-- La propiedad es
prop_equivalencia :: [Int] -> Bool
prop_equivalencia xs =
  eliminaciones xs == eliminaciones2 xs

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

import Test.QuickCheck (quickCheck)

-- 1ª solución

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

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

eliminaciones2 xs =

[(v,i,us++vs) | i <- [0..length xs - 1],

let (us,v:vs) = splitAt i xs]

-- Comprobación de equivalencia

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

-- La propiedad es

prop_equivalencia :: [Int] -> Bool

prop_equivalencia xs =

eliminaciones xs == eliminaciones2 xs

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

Ordenación de ternas de enteros

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

Las ternas de números enteros positivos se pueden ordenar por su suma y las de la misma suma por orden lexicográfico. Por ejemplo,

ternas de suma 3:

   (1,1,1)

(1,1,1)

ternas de suma 4:

   (1,1,2),(1,2,1),(2,1,1)

1	(1,1,2),(1,2,1),(2,1,1)

ternas de suma 5:

   (1,1,3),(1,2,2),(1,3,1),(2,1,2),(2,2,1),(3,1,1)

1	(1,1,3),(1,2,2),(1,3,1),(2,1,2),(2,2,1),(3,1,1)

ternas de suma 6

   (1,1,4),(1,2,3),(1,3,2),(1,4,1),(2,1,3),(2,2,2),(2,3,1),(3,1,2),(3,2,1),(4,1,1)

1	(1,1,4),(1,2,3),(1,3,2),(1,4,1),(2,1,3),(2,2,2),(2,3,1),(3,1,2),(3,2,1),(4,1,1)

y así sucesivamente.

Definir la función

   ternas :: [(integer,integer,integer)]

1	ternas :: [(integer,integer,integer)]

tal que ternas es la lista de las ternas de enteros positivos con el orden descrito anteriormente. por ejemplo,

   λ> take 20 ternas
   [(1,1,1),
    (1,1,2),(1,2,1),(2,1,1),
    (1,1,3),(1,2,2),(1,3,1),(2,1,2),(2,2,1),(3,1,1),
    (1,1,4),(1,2,3),(1,3,2),(1,4,1),(2,1,3),(2,2,2),(2,3,1),(3,1,2),(3,2,1),(4,1,1)]

λ> take 20 ternas

[(1,1,1),

(1,1,2),(1,2,1),(2,1,1),

(1,1,3),(1,2,2),(1,3,1),(2,1,2),(2,2,1),(3,1,1),

(1,1,4),(1,2,3),(1,3,2),(1,4,1),(2,1,3),(2,2,2),(2,3,1),(3,1,2),(3,2,1),(4,1,1)]

Soluciones

import Data.List (nub, permutations, sort)

ternas :: [(Integer,Integer,Integer)]
ternas = concatMap ternasSuma [3..]

-- (ternasSuma n) es la lista de las ternas de enteros positivos cuya
-- suma es n ordenadas lexicográficamte. Por ejemplo,
--    λ> ternasSuma 3
--    [(1,1,1)]
--    λ> ternasSuma 4
--    [(1,1,2),(1,2,1),(2,1,1)]
--    λ> ternasSuma 5
--    [(1,1,3),(1,2,2),(1,3,1),(2,1,2),(2,2,1),(3,1,1)]
--    λ> ternasSuma 6
--    [(1,1,4),(1,2,3),(1,3,2),(1,4,1),(2,1,3),(2,2,2),(2,3,1),(3,1,2),(3,2,1),(4,1,1)]
ternasSuma :: Integer -> [(Integer,Integer,Integer)]
ternasSuma n =
  sort (concatMap permutaciones [(a,b,c) | a <- [1..n]
                                         , b <- [a..n]
                                         , let c = n-a-b
                                         , b <= c])

-- (permutaciones t) es la lista de las permutaciones de la terna t. Por ejemplo,
--    λ> permutaciones (1,2,3)
--    [(1,2,3),(2,1,3),(3,2,1),(2,3,1),(3,1,2),(1,3,2)]
--    λ> permutaciones (1,1,2)
--    [(1,1,2),(2,1,1),(1,2,1)]
--    λ> permutaciones (1,1,1)
--    [(1,1,1)]
permutaciones :: (Integer,Integer,Integer) -> [(Integer,Integer,Integer)]
permutaciones (a,b,c) =
  nub [(x,y,z) | [x,y,z] <- permutations [a,b,c]]

import Data.List (nub, permutations, sort)

ternas :: [(Integer,Integer,Integer)]

ternas = concatMap ternasSuma [3..]

-- (ternasSuma n) es la lista de las ternas de enteros positivos cuya

-- suma es n ordenadas lexicográficamte. Por ejemplo,

-- λ> ternasSuma 3

-- [(1,1,1)]

-- λ> ternasSuma 4

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

-- λ> ternasSuma 5

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

-- λ> ternasSuma 6

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

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

ternasSuma n =

sort (concatMap permutaciones [(a,b,c) | a <- [1..n]

, b <- [a..n]

, let c = n-a-b

, b <= c])

-- (permutaciones t) es la lista de las permutaciones de la terna t. Por ejemplo,

-- λ> permutaciones (1,2,3)

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

-- λ> permutaciones (1,1,2)

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

-- λ> permutaciones (1,1,1)

-- [(1,1,1)]

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

permutaciones (a,b,c) =

nub [(x,y,z) | [x,y,z] <- permutations [a,b,c]]

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>

Pares con múltiplos con igual número de divisores

PorJosé A. Alonso 4-febrero-202111-febrero-2021

Definir la función

   paresNoDivisible :: [(Integer, Integer)]

1	paresNoDivisible :: [(Integer, Integer)]

tal que paresNoDivisible es la lista de los pares (n,k) tales que n < k y k no es divisible por n. Por ejemplo,

   λ> take 10 paresNoDivisible
   [(2,3),(3,4),(2,5),(3,5),(4,5),(4,6),(5,6),(2,7),(3,7),(4,7)]

1 2	λ> take 10 paresNoDivisible [(2,3),(3,4),(2,5),(3,5),(4,5),(4,6),(5,6),(2,7),(3,7),(4,7)]

Se observa que en el resultado los pares se ordenan primero según su segundo elemento y los que tienen el mismo segundo elemento se ordenan por el primer elemento.

Un par especial es un par de enteros positivos (n,k) tales que existe algún s tal que $s \times n$ y $s \times k$ tienen el mismo número de divisores. Por ejemplo, (3,4) es un par especial ya que $2 \times 3$ y $2 \times 4$ tienen 4 divisores.

Comprobar con QuickCheck todos los elementos de paresNoDivisible son pares especiales.

Nota: Este ejercicio está basado en el problema N1 de la Olimpíada Internacional de Matemáticas (IMO) del 2018.

Soluciones

import Data.List (genericLength, group)
import Data.Numbers.Primes (primeFactors)
import Test.QuickCheck (Property, (==>), quickCheck)

-- Definición de paresNoDivisible
-- ==============================

paresNoDivisible :: [(Integer, Integer)]
paresNoDivisible =
  filter parNoDivisible pares

-- pares es la lista de los pares de enteros positivos ordenados primero
-- según su segundo elemento y los que tienen el mismo segundo elemento
-- están ordenados por el primer elemento. Por ejemplo,
--    λ> take 10 pares
--    [(1,2),(1,3),(2,3),(1,4),(2,4),(3,4),(1,5),(2,5),(3,5),(4,5)]
pares :: [(Integer, Integer)]
pares =
  [(n,k) | k <- [1..]
         , n <- [1..k-1]]

-- (parNoDivisible (n,k)) se verifica si n < k y k no es divisible por
-- n. Por ejemplo,
--    parNoDivisible (2,3)  ==  True
--    parNoDivisible (2,4)  ==  False
--    parNoDivisible (3,2)  ==  False
parNoDivisible :: (Integer, Integer) -> Bool
parNoDivisible (n,k) =
  n < k &&
  k `mod` n  /= 0

-- Definiciones de parEspecial
-- ===========================

-- Para expresar la propiedad se define la función
--    parEspecial :: (Integer, Integer) -> Bool
-- tal que (parEspecial (n,k)) se verifica si existe algún s tal que s*n
-- y s*k tienen el mismo número de divisores. Por ejemplo, {-# SCC "" #-}
--    parEspecial (3,4)  ==  True
--
-- Nota: La función parEspecial es una función parcial ya que sólo
-- termina para los pares especiales.

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

parEspecial1 :: (Integer, Integer) -> Bool
parEspecial1 (n,k) =
  n < k && not (null [s | s <- [1..]
                       , numeroDivisores (s * n) ==
                         numeroDivisores (s * k)])

-- (numeroDivisores n) es el número de divisores de n. Por ejemplo,
--    numeroDivisores 12  ==  6
--    numeroDivisores 14  ==  4
numeroDivisores :: Integer -> Integer
numeroDivisores n =
  genericLength [x | x <- [1..n]
                   , n `mod` x == 0]

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

parEspecial2 :: (Integer, Integer) -> Bool
parEspecial2 (n,k) =
  n < k && not (null [s | s <- [1..]
                       , numeroDivisores2 (s * n) ==
                         numeroDivisores2 (s * k)])

-- (numeroDivisores2 n) es el número de divisores de n. Por ejemplo,
--    numeroDivisores2 12  ==  6
--    numeroDivisores2 14  ==  4
numeroDivisores2 :: Integer -> Integer
numeroDivisores2 =
  product . map ((+1) . genericLength) . group . primeFactors

-- Comparación de eficiencia de definiciones de parEspecial
-- --------------------------------------------------------

-- La comparación es
--    λ> parEspecial1 (9,30)
--    True
--    (28.24 secs, 15,625,373,696 bytes)
--    λ> parEspecial2 (9,30)
--    True
--    (0.06 secs, 58,698,264 bytes)

-- En lo que sigue, usaremos la 2ª definición
parEspecial :: (Integer, Integer) -> Bool
parEspecial = parEspecial2

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

-- La propiedad es
prop_paresNoDivisible :: Int -> Property
prop_paresNoDivisible i =
  i >= 0 ==>
  parEspecial (paresNoDivisible !! i)

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

100

101

102

103

import Data.List (genericLength, group)

import Data.Numbers.Primes (primeFactors)

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

-- Definición de paresNoDivisible

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

paresNoDivisible :: [(Integer, Integer)]

paresNoDivisible =

filter parNoDivisible pares

-- pares es la lista de los pares de enteros positivos ordenados primero

-- según su segundo elemento y los que tienen el mismo segundo elemento

-- están ordenados por el primer elemento. Por ejemplo,

-- λ> take 10 pares

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

pares :: [(Integer, Integer)]

pares =

[(n,k) | k <- [1..]

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

-- (parNoDivisible (n,k)) se verifica si n < k y k no es divisible por

-- n. Por ejemplo,

-- parNoDivisible (2,3) == True

-- parNoDivisible (2,4) == False

-- parNoDivisible (3,2) == False

parNoDivisible :: (Integer, Integer) -> Bool

parNoDivisible (n,k) =

n < k &&

k `mod` n /= 0

-- Definiciones de parEspecial

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

-- Para expresar la propiedad se define la función

-- parEspecial :: (Integer, Integer) -> Bool

-- tal que (parEspecial (n,k)) se verifica si existe algún s tal que s*n

-- y s*k tienen el mismo número de divisores. Por ejemplo, {-# SCC "" #-}

-- parEspecial (3,4) == True

-- Nota: La función parEspecial es una función parcial ya que sólo

-- termina para los pares especiales.

-- 1ª definición de parEspecial

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

parEspecial1 :: (Integer, Integer) -> Bool

parEspecial1 (n,k) =

n < k && not (null [s | s <- [1..]

, numeroDivisores (s * n) ==

numeroDivisores (s * k)])

-- (numeroDivisores n) es el número de divisores de n. Por ejemplo,

-- numeroDivisores 12 == 6

-- numeroDivisores 14 == 4

numeroDivisores :: Integer -> Integer

numeroDivisores n =

genericLength [x | x <- [1..n]

, n `mod` x == 0]

-- 2ª definición de parEspecial

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

parEspecial2 :: (Integer, Integer) -> Bool

parEspecial2 (n,k) =

n < k && not (null [s | s <- [1..]

, numeroDivisores2 (s * n) ==

numeroDivisores2 (s * k)])

-- (numeroDivisores2 n) es el número de divisores de n. Por ejemplo,

-- numeroDivisores2 12 == 6

-- numeroDivisores2 14 == 4

numeroDivisores2 :: Integer -> Integer

numeroDivisores2 =

product . map ((+1) . genericLength) . group . primeFactors

-- Comparación de eficiencia de definiciones de parEspecial

-- --------------------------------------------------------

-- La comparación es

-- λ> parEspecial1 (9,30)

-- True

-- (28.24 secs, 15,625,373,696 bytes)

-- λ> parEspecial2 (9,30)

-- True

-- (0.06 secs, 58,698,264 bytes)

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

parEspecial :: (Integer, Integer) -> Bool

parEspecial = parEspecial2

-- Propiedad

-- =========

-- La propiedad es

prop_paresNoDivisible :: Int -> Property

prop_paresNoDivisible i =

i >= 0 ==>

parEspecial (paresNoDivisible !! i)

-- La comprobación es

-- λ> quickCheck prop_paresNoDivisible

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

Potencias de dos más cercanas

PorJosé A. Alonso 25-enero-20211-febrero-2021

Definir la función

   potenciasDeDosMasCercanas :: [Integer] -> [Integer]

1	potenciasDeDosMasCercanas :: [Integer] -> [Integer]

tal que (potenciasDeDosMasCercanas xs) es la lista sustituyendo cada elemento de xs por su potencia de dos más cercana (en el caso de que haya dos equidistantes se elige la menor). Por ejemplo,

   potenciasDeDosMasCercanas2 [6,7,8,9,2021]  ==  [4,8,8,8,2048]

1	potenciasDeDosMasCercanas2 [6,7,8,9,2021] == [4,8,8,8,2048]

Soluciones

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

potenciasDeDosMasCercanas :: [Integer] -> [Integer]
potenciasDeDosMasCercanas = map potenciaDeDosMasCercana

-- (potenciaDeDosMasCercana n) es la potencia de dos más cercana (en el
-- caso de que haya dos equidistantes se elige la menor). Por ejemplo,
--    potenciaDeDosMasCercana 6  ==  4
--    potenciaDeDosMasCercana 7  ==  8
--    potenciaDeDosMasCercana 8  ==  8
--    potenciaDeDosMasCercana 9  ==  8
potenciaDeDosMasCercana :: Integer -> Integer
potenciaDeDosMasCercana n
  | dx <= dy  = x
  | otherwise = y
  where (x,y) = potenciasDeDosCercanas n
        dx    = n - x
        dy    = y - n

-- (potenciasDeDosMasCercanas n) es par formado por las dos potencias de
-- dos más cercana a n. Por ejemplo,
--    potenciasDeDosCercanas 6  ==  (4,8)
--    potenciasDeDosCercanas 7  ==  (4,8)
--    potenciasDeDosCercanas 8  ==  (4,8)
--    potenciasDeDosCercanas 9  ==  (8,16)
potenciasDeDosCercanas :: Integer -> (Integer, Integer)
potenciasDeDosCercanas n =
  (x `div` 2, x)
  where x = menorPotenciaDeDosMayorOIgual n

-- (menorPotenciaDeDosMayorOIgual n) es la menor potencia de dos mayor o
-- igual que n. Por ejemplo,
--    menorPotenciaDeDosMayorOIgual 6  ==  8
--    menorPotenciaDeDosMayorOIgual 8  ==  8
menorPotenciaDeDosMayorOIgual :: Integer -> Integer
menorPotenciaDeDosMayorOIgual n =
  head [2^x | x <- [0..], 2^x >= n]

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

potenciasDeDosMasCercanas2 :: [Integer] -> [Integer]
potenciasDeDosMasCercanas2 = map potenciaDeDosMasCercana2

potenciaDeDosMasCercana2 :: Integer -> Integer
potenciaDeDosMasCercana2 n =
  snd (min (n-x,x) (y-n,y))
  where (x,y) = potenciasDeDosCercanas2 n

potenciasDeDosCercanas2 :: Integer -> (Integer, Integer)
potenciasDeDosCercanas2 n = (x `div` 2, x)
  where (x:_) = dropWhile (<n) potenciasDeDos

-- potenciasDeDos es la lista de las potencias de dos. Por ejemplo,
--    take 11 potenciasDeDos  ==  [1,2,4,8,16,32,64,128,256,512,1024]
potenciasDeDos :: [Integer]
potenciasDeDos = iterate (*2) 1

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

-- La comparación es
--    λ> maximum (potenciasDeDosMasCercanas [10^5..10^6])
--    1048576
--    (18.28 secs, 20,835,181,624 bytes)
--    λ> maximum (potenciasDeDosMasCercanas2 [10^5..10^6])
--    1048576
--    (2.44 secs, 830,307,736 bytes)

-- 1ª solución

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

potenciasDeDosMasCercanas :: [Integer] -> [Integer]

potenciasDeDosMasCercanas = map potenciaDeDosMasCercana

-- (potenciaDeDosMasCercana n) es la potencia de dos más cercana (en el

-- caso de que haya dos equidistantes se elige la menor). Por ejemplo,

-- potenciaDeDosMasCercana 6 == 4

-- potenciaDeDosMasCercana 7 == 8

-- potenciaDeDosMasCercana 8 == 8

-- potenciaDeDosMasCercana 9 == 8

potenciaDeDosMasCercana :: Integer -> Integer

potenciaDeDosMasCercana n

| dx <= dy = x

| otherwise = y

where (x,y) = potenciasDeDosCercanas n

dx = n - x

dy = y - n

-- (potenciasDeDosMasCercanas n) es par formado por las dos potencias de

-- dos más cercana a n. Por ejemplo,

-- potenciasDeDosCercanas 6 == (4,8)

-- potenciasDeDosCercanas 7 == (4,8)

-- potenciasDeDosCercanas 8 == (4,8)

-- potenciasDeDosCercanas 9 == (8,16)

potenciasDeDosCercanas :: Integer -> (Integer, Integer)

potenciasDeDosCercanas n =

(x `div` 2, x)

where x = menorPotenciaDeDosMayorOIgual n

-- (menorPotenciaDeDosMayorOIgual n) es la menor potencia de dos mayor o

-- igual que n. Por ejemplo,

-- menorPotenciaDeDosMayorOIgual 6 == 8

-- menorPotenciaDeDosMayorOIgual 8 == 8

menorPotenciaDeDosMayorOIgual :: Integer -> Integer

menorPotenciaDeDosMayorOIgual n =

head [2^x | x <- [0..], 2^x >= n]

-- 2ª solución

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

potenciasDeDosMasCercanas2 :: [Integer] -> [Integer]

potenciasDeDosMasCercanas2 = map potenciaDeDosMasCercana2

potenciaDeDosMasCercana2 :: Integer -> Integer

potenciaDeDosMasCercana2 n =

snd (min (n-x,x) (y-n,y))

where (x,y) = potenciasDeDosCercanas2 n

potenciasDeDosCercanas2 :: Integer -> (Integer, Integer)

potenciasDeDosCercanas2 n = (x `div` 2, x)

where (x:_) = dropWhile (<n) potenciasDeDos

-- potenciasDeDos es la lista de las potencias de dos. Por ejemplo,

-- take 11 potenciasDeDos == [1,2,4,8,16,32,64,128,256,512,1024]

potenciasDeDos :: [Integer]

potenciasDeDos = iterate (*2) 1

-- Comparación de eficiencia

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

-- La comparación es

-- λ> maximum (potenciasDeDosMasCercanas [10^5..10^6])

-- 1048576

-- (18.28 secs, 20,835,181,624 bytes)

-- λ> maximum (potenciasDeDosMasCercanas2 [10^5..10^6])

-- 1048576

-- (2.44 secs, 830,307,736 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>

Números de Perrin

PorJosé A. Alonso 10-junio-201925-abril-2021

Los números de Perrin se definen por la elación de recurrencia

   P(n) = P(n - 2) + P(n - 3) si n > 2,

1	P(n) = P(n - 2) + P(n - 3) si n > 2,

con los valores iniciales

   P(0) = 3, P(1) = 0 y P(2) = 2.

1	P(0) = 3, P(1) = 0 y P(2) = 2.

Definir la sucesión

   sucPerrin :: [Integer]

1	sucPerrin :: [Integer]

cuyos elementos son los números de Perrin. Por ejemplo,

   λ> take 15 sucPerrin
   [3,0,2,3,2,5,5,7,10,12,17,22,29,39,51]
   λ> length (show (sucPerrin !! (2*10^5)))
   24425

λ> take 15 sucPerrin

[3,0,2,3,2,5,5,7,10,12,17,22,29,39,51]

λ> length (show (sucPerrin !! (2*10^5)))

24425

Comprobar con QuickCheck si se verifica la siguiente propiedad: para todo entero n > 1, el n-ésimo término de la sucesión de Perrin es divisible por n si y sólo si n es primo.

Soluciones

[schedule expon=’2019-06-12′ expat=»06:00″]

Las soluciones se pueden escribir en los comentarios hasta el 12 de junio.
El código se debe escribir entre una línea con <pre lang=»haskell»> y otra con </pre>

Pensamiento

Encuentro lo que no busco:
las hojas del toronjil
huelen a limón maduro.

Antonio Machado

[/schedule]

[schedule on=’2019-06-12′ at=»06:00″]

import Data.List (genericIndex, unfoldr)
import Data.Numbers.Primes (isPrime)
import Test.QuickCheck

-- 1ª solución
sucPerrin1 :: [Integer]
sucPerrin1 = 3 : 0 : 2 : zipWith (+) sucPerrin1 (tail sucPerrin1)

-- 2ª solución
sucPerrin2 :: [Integer]
sucPerrin2 = [x | (x,_,_) <- iterate op (3,0,2)]
  where op (a,b,c) = (b,c,a+b)
 
-- 3ª solución
sucPerrin3 :: [Integer]
sucPerrin3 =
  unfoldr (\(a, (b,c)) -> Just (a, (b,(c,a+b)))) (3,(0,2))

-- Comparación de eficiencia
--    λ> length (show (sucPerrin1 !! (10^5)))
--    12213
--    (1.44 secs, 295,373,680 bytes)
--    λ> length (show (sucPerrin2 !! (10^5)))
--    12213
--    (1.22 secs, 301,493,408 bytes)
--    λ> length (show (sucPerrin3 !! (10^5)))
--    12213
--    (0.86 secs, 296,911,304 bytes)

-- Usaremos la 3ª
sucPerrin :: [Integer]
sucPerrin = sucPerrin3

-- La propiedad es  
conjeturaPerrin :: Integer -> Property
conjeturaPerrin n =
  n > 1 ==>
  (perrin n `mod` n == 0) == isPrime n

-- (perrin n) es el n-ésimo término de la sucesión de Perrin. Por
-- ejemplo,
--    perrin 4  ==  2
--    perrin 5  ==  5
--    perrin 6  ==  5
perrin :: Integer -> Integer
perrin n = sucPerrin `genericIndex` n

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

-- Nota: Aunque QuickCheck no haya encontrado contraejemplos, la
-- propiedad no es cierta. Sólo lo es una de las implicaciones: si n es
-- primo, entonces el  n-ésimo término de la sucesión de Perrin es
-- divisible por n. La otra es falsa y los primeros contraejemplos son
--    271441, 904631, 16532714, 24658561, 27422714, 27664033, 46672291

import Data.List (genericIndex, unfoldr)

import Data.Numbers.Primes (isPrime)

import Test.QuickCheck

-- 1ª solución

sucPerrin1 :: [Integer]

sucPerrin1 = 3 : 0 : 2 : zipWith (+) sucPerrin1 (tail sucPerrin1)

-- 2ª solución

sucPerrin2 :: [Integer]

sucPerrin2 = [x | (x,_,_) <- iterate op (3,0,2)]

where op (a,b,c) = (b,c,a+b)

-- 3ª solución

sucPerrin3 :: [Integer]

sucPerrin3 =

unfoldr (\(a, (b,c)) -> Just (a, (b,(c,a+b)))) (3,(0,2))

-- Comparación de eficiencia

-- λ> length (show (sucPerrin1 !! (10^5)))

-- 12213

-- (1.44 secs, 295,373,680 bytes)

-- λ> length (show (sucPerrin2 !! (10^5)))

-- 12213

-- (1.22 secs, 301,493,408 bytes)

-- λ> length (show (sucPerrin3 !! (10^5)))

-- 12213

-- (0.86 secs, 296,911,304 bytes)

-- Usaremos la 3ª

sucPerrin :: [Integer]

sucPerrin = sucPerrin3

-- La propiedad es

conjeturaPerrin :: Integer -> Property

conjeturaPerrin n =

n > 1 ==>

(perrin n `mod` n == 0) == isPrime n

-- (perrin n) es el n-ésimo término de la sucesión de Perrin. Por

-- ejemplo,

-- perrin 4 == 2

-- perrin 5 == 5

-- perrin 6 == 5

perrin :: Integer -> Integer

perrin n = sucPerrin `genericIndex` n

-- La comprobación es

-- λ> quickCheck conjeturaPerrin

-- +++ OK, passed 100 tests.

-- Nota: Aunque QuickCheck no haya encontrado contraejemplos, la

-- propiedad no es cierta. Sólo lo es una de las implicaciones: si n es

-- primo, entonces el n-ésimo término de la sucesión de Perrin es

-- divisible por n. La otra es falsa y los primeros contraejemplos son

-- 271441, 904631, 16532714, 24658561, 27422714, 27664033, 46672291

[/schedule]

Sucesión fractal

PorJosé A. Alonso 7-junio-201925-abril-2021

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

[schedule expon=’2019-06-14′ expat=»06:00″]

Las soluciones se pueden escribir en los comentarios hasta el 14 de junio.
El código se debe escribir entre una línea con <pre lang=»haskell»> y otra con </pre>

Pensamiento

«O rinnovarsi o perire …»
No me suena bien.
«Navigare è necessario …»
Mejor: ¡vivir para ver!

Antonio Machado

[/schedule]

[schedule on=’2019-06-14′ at=»06:00″]

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

[/schedule]

Número primo de Sheldon

PorJosé A. Alonso 5-junio-20194-junio-2019

En el episodio número 73 de la serie «The Big Bang Theory», Sheldon Cooper enuncia lo siguiente:

«El mejor número es el 73. El 73 es el 21-ésimo número primo. Al invertir sus cifras obtenemos 37, que es el primo número 12. Y al invertir este obtenemos 21, que es el producto de, agarraos fuerte, 7 y 3.»

Se define un número primo de Sheldon como: el n-ésimo número primo p(n) será un primo de Sheldon si cumple que el producto de sus dígitos es n y si, además, el número que se obtiene al invertir sus cifras, rev(p(n)), es el rev(n)-ésimo número primo; es decir, si rev(p(n)) = p(rev(n)).

Definir la función

   esPrimoSheldon :: Int -> Bool

1	esPrimoSheldon :: Int -> Bool

tal que (esPrimoSheldon x) se verifica si x un primo de Sheldon. Por ejemplo,

_ 
   esPrimoSheldon 73  ==  True
   esPrimoSheldon 79  ==  False

esPrimoSheldon 73 == True

esPrimoSheldon 79 == False

Comprobar con QuickCheck que 73 es el único primo de Sheldon.

Referencia: Este ejercicio está basado en la noticia Descubierta una nueva propiedad de los números primos gracias a The Big Bang Theory donde podéis leer más información sobre el tema, entre ello la prueba de que el 73 es el único número primo de Sheldon.

Nota: Este ejercicio ha sido propuesto por Ángel Ruiz Campos.

Soluciones

[schedule expon=’2019-06-12′ expat=»06:00″]

Las soluciones se pueden escribir en los comentarios hasta el 12 de junio.
El código se debe escribir entre una línea con <pre lang=»haskell»> y otra con </pre>

Pensamiento

El mejor número es el 73. El 73 es el 21-ésimo número primo. Al invertir sus cifras obtenemos 37, que es el primo número 12. Y al invertir este obtenemos 21, que es el producto de, agarraos fuerte, 7 y 3.

Sheldon Cooper

[/schedule]

[schedule on=’2019-06-12′ at=»06:00″]

import Data.Char           (digitToInt)
import Data.List           (elemIndex)
import Data.Maybe          (fromJust)
import Data.Numbers.Primes (isPrime, primes)
import Test.QuickCheck     (Property, (==>), quickCheck)

-- 1ª definición
-- =============

esPrimoSheldon :: Int -> Bool
esPrimoSheldon x =
     n > 0
  && x == primes !! (n - 1)
  && inverso x == primes !! (inverso n - 1)
  where n = productoDigitos x

-- (productoDigitos x) es el producto de los dígitos de x. Por ejemplo, 
--    productoDigitos 73  ==  21
productoDigitos :: Int -> Int
productoDigitos x = product (map digitToInt (show x))

-- (inverso x) es el número obtenido invirtiendo el orden de los dígitos
-- de x. Por ejemplo,
--    inverso 735  ==  537
inverso :: Int -> Int
inverso x = read (reverse (show x))

-- 2ª definición
-- =============

esPrimoSheldon2 :: Int -> Bool
esPrimoSheldon2 x =
     n > 0
  && x == primes !! (n - 1)
  && inverso2 x == primes !! (inverso2 n - 1)
  where n = productoDigitos2 x

-- (productoDigitos2 x) es el producto de los dígitos de x. Por ejemplo, 
--    productoDigitos2 73  ==  21
productoDigitos2 :: Int -> Int
productoDigitos2 = product . map digitToInt . show

-- (inverso2 x) es el número obtenido invirtiendo el orden de los dígitos
-- de x. Por ejemplo,
--    inverso2 735  ==  537
inverso2 :: Int -> Int
inverso2 = read . reverse . show

-- 3ª definición
-- =============

esPrimoSheldon3 :: Int -> Bool
esPrimoSheldon3 n = isPrime n && p1 && p2
  where p  = primes
        i1 = fromJust (elemIndex n p) + 1
        i2 = read (reverse (show i1))
        p1 = i1 == product (map digitToInt (show n))
        p2 = read (reverse (show n)) == p !! (i2 - 1)

-- Propiedad de primo de Sheldon
-- =============================

-- La propiedad es
prop_primoDeShelldon :: Int -> Property
prop_primoDeShelldon x =
  x >= 0 ==> esPrimoSheldon x == (x == 73)

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

import Data.Char (digitToInt)

import Data.List (elemIndex)

import Data.Maybe (fromJust)

import Data.Numbers.Primes (isPrime, primes)

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

-- 1ª definición

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

esPrimoSheldon :: Int -> Bool

esPrimoSheldon x =

n > 0

&& x == primes !! (n - 1)

&& inverso x == primes !! (inverso n - 1)

where n = productoDigitos x

-- (productoDigitos x) es el producto de los dígitos de x. Por ejemplo,

-- productoDigitos 73 == 21

productoDigitos :: Int -> Int

productoDigitos x = product (map digitToInt (show x))

-- (inverso x) es el número obtenido invirtiendo el orden de los dígitos

-- de x. Por ejemplo,

-- inverso 735 == 537

inverso :: Int -> Int

inverso x = read (reverse (show x))

-- 2ª definición

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

esPrimoSheldon2 :: Int -> Bool

esPrimoSheldon2 x =

n > 0

&& x == primes !! (n - 1)

&& inverso2 x == primes !! (inverso2 n - 1)

where n = productoDigitos2 x

-- (productoDigitos2 x) es el producto de los dígitos de x. Por ejemplo,

-- productoDigitos2 73 == 21

productoDigitos2 :: Int -> Int

productoDigitos2 = product . map digitToInt . show

-- (inverso2 x) es el número obtenido invirtiendo el orden de los dígitos

-- de x. Por ejemplo,

-- inverso2 735 == 537

inverso2 :: Int -> Int

inverso2 = read . reverse . show

-- 3ª definición

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

esPrimoSheldon3 :: Int -> Bool

esPrimoSheldon3 n = isPrime n && p1 && p2

where p = primes

i1 = fromJust (elemIndex n p) + 1

i2 = read (reverse (show i1))

p1 = i1 == product (map digitToInt (show n))

p2 = read (reverse (show n)) == p !! (i2 - 1)

-- Propiedad de primo de Sheldon

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

-- La propiedad es

prop_primoDeShelldon :: Int -> Property

prop_primoDeShelldon x =

x >= 0 ==> esPrimoSheldon x == (x == 73)

-- La comprobación es

-- λ> quickCheck prop_primoDeShelldon

-- +++ OK, passed 100 tests.

[/schedule]

Grafo de divisibilidad

PorJosé A. Alonso 3-junio-201926-marzo-2022

El grafo de divisibilidad de orden n es el grafo cuyos nodos son los números naturales entre 1 y n, cuyas aristas son los pares (x,y) tales que x divide a y o y divide a x. El coste de cada arista es el cociente entre su mayor y menor elemento.

Definir las siguientes funciones:

   grafoDivisibilidad :: Int -> Grafo Int Int
   coste              :: Int -> Int

1 2	grafoDivisibilidad :: Int -> Grafo Int Int coste :: Int -> Int

tales que

(grafoDivisibilidad n) es el grafo de divisibilidad de orden n. Por ejemplo,

      λ> grafoDivisibilidad 12
      G ND (array (1,12)
                  [(1,[(2,2),(3,3),(4,4),(5,5),(6,6),(7,7),
                       (8,8),(9,9),(10,10),(11,11),(12,12)]),
                   (2,[(1,2),(4,2),(6,3),(8,4),(10,5),(12,6)]),
                   (3,[(1,3),(6,2),(9,3),(12,4)]),
                   (4,[(1,4),(2,2),(8,2),(12,3)]),
                   (5,[(1,5),(10,2)]),
                   (6,[(1,6),(2,3),(3,2),(12,2)]),
                   (7,[(1,7)]),
                   (8,[(1,8),(2,4),(4,2)]),
                   (9,[(1,9),(3,3)]),
                   (10,[(1,10),(2,5),(5,2)]),
                   (11,[(1,11)]),
                   (12,[(1,12),(2,6),(3,4),(4,3),(6,2)])])

λ> grafoDivisibilidad 12

G ND (array (1,12)

[(1,[(2,2),(3,3),(4,4),(5,5),(6,6),(7,7),

(8,8),(9,9),(10,10),(11,11),(12,12)]),

(2,[(1,2),(4,2),(6,3),(8,4),(10,5),(12,6)]),

(3,[(1,3),(6,2),(9,3),(12,4)]),

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

(5,[(1,5),(10,2)]),

(6,[(1,6),(2,3),(3,2),(12,2)]),

(7,[(1,7)]),

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

(9,[(1,9),(3,3)]),

(10,[(1,10),(2,5),(5,2)]),

(11,[(1,11)]),

(12,[(1,12),(2,6),(3,4),(4,3),(6,2)])])

(coste n) es el coste del árbol de expansión mínimo del grafo de divisibilidad de orden n. Por ejemplo,

      coste 12        ==  41
      coste 3000      ==  605305
      coste (2*10^5)  ==  1711798835

coste 12 == 41

coste 3000 == 605305

coste (2*10^5) == 1711798835

Soluciones

[schedule expon=’2019-06-10′ expat=»06:00″]

Las soluciones se pueden escribir en los comentarios hasta el 10 de junio.
El código se debe escribir entre una línea con <pre lang=»haskell»> y otra con </pre>

Pensamiento

Malos sueños he.
Me despertaré.

Antonio Machado

[/schedule]

[schedule on=’2019-06-10′ at=»06:00″]

import Data.Ix
import Data.List (delete, sort)
import qualified Data.Set as S
import I1M.Grafo
import I1M.Tabla
import Data.Numbers.Primes (primeFactors)

-- Definición de grafoDivisibilidad
-- ================================

grafoDivisibilidad :: Int -> Grafo Int Int
grafoDivisibilidad n =
  creaGrafo ND (1,n) [(x,y,y `div` x) | y <- [1..n]
                                      , x <- [1..y-1]
                                      , y `mod` x == 0]

-- 1ª definición de coste (con el algoritmo de Kruskal)
-- ====================================================

coste1 :: Int -> Int
coste1 n = sum [p | (p,x,y) <- kruskal (grafoDivisibilidad n)]

-- (kruskal g) es el árbol de expansión mínimo del grafo g calculado
-- mediante el algoritmo de Kruskal. Por ejemplo,
--    λ> kruskal (grafoDivisibilidad 12)
--    [(11,1,11),(7,1,7),(5,1,5),(3,3,9),(3,1,3),(2,6,12),(2,5,10),
--     (2,4,8),(2,3,6),(2,2,4),(2,1,2)]
kruskal :: (Ix v, Num p, Ord p) => Grafo v p -> [(p,v,v)]
kruskal g = kruskal' cola                           -- Cola ordenada
                     (tabla [(x,x) | x <- nodos g]) -- Tabla de raices
                     []                             -- Árbol de expansión
                     (length (nodos g) - 1)         -- Aristas por
                                                    -- colocar
    where cola = sort [(p,x,y) | (x,y,p) <- aristas g]

kruskal' ((p,x,y):as) t ae n 
  | n == 0      = ae
  | actualizado = kruskal' as t' ((p,x,y):ae) (n-1)
  | otherwise   = kruskal' as t  ae           n
  where (actualizado,t') = buscaActualiza (x,y) t

-- (raiz t n) es la raíz de n en la tabla t. Por ejemplo,
--    raiz (crea [(1,1),(3,1),(4,3),(5,4),(2,6),(6,6)]) 5  == 1
--    raiz (crea [(1,1),(3,1),(4,3),(5,4),(2,6),(6,6)]) 2  == 6
raiz:: Eq n => Tabla n n -> n -> n
raiz t x | v == x    = v
         | otherwise = raiz t v
         where v = valor t x

-- (buscaActualiza a t) es el par formado por False y la tabla t, si los
-- dos vértices de la arista a tienen la misma raíz en t y el par
-- formado por True y la tabla obtenida añadiéndole a t la arista
-- formada por el vértice de a de mayor raíz y la raíz del vértice de
-- a de menor raíz. Por ejemplo,
--    ghci> let t = crea [(1,1),(2,2),(3,1),(4,1)]
--    ghci> buscaActualiza (2,3) t
--    (True,Tbl [(1,1),(2,1),(3,1),(4,1)])
--    ghci> buscaActualiza (3,4) t
--    (False,Tbl [(1,1),(2,2),(3,1),(4,1)])
buscaActualiza :: (Eq n, Ord n) => (n,n) -> Tabla n n -> (Bool,Tabla n n)
buscaActualiza (x,y) t 
  | x' == y'  = (False, t) 
  | y' <  x'  = (True, modifica (x,y') t)
  | otherwise = (True, modifica (y,x') t)
  where x' = raiz t x 
        y' = raiz t y

-- 2ª definición de coste (con el algoritmo de Prim)
-- =================================================

coste2 :: Int -> Int
coste2 n = sum [p | (p,x,y) <- prim (grafoDivisibilidad n)]

-- (prim g) es el árbol de expansión mínimo del grafo g calculado
-- mediante el algoritmo de Prim. Por ejemplo,
--    λ> prim (grafoDivisibilidad 12)
--    [(11,1,11),(7,1,7),(2,5,10),(5,1,5),(3,3,9),(2,6,12),(2,3,6),
--     (3,1,3),(2,4,8),(2,2,4),(2,1,2)]
prim :: (Ix v, Num p, Ord p) => Grafo v p -> [(p,v,v)]
prim g = prim' [n]              -- Nodos colocados
               ns               -- Nodos por colocar 
               []               -- Árbol de expansión
               (aristas g)      -- Aristas del grafo
         where (n:ns) = nodos g

prim' t [] ae as = ae
prim' t r  ae as = prim' (v':t) (delete v' r) (e:ae) as
  where e@(c,u', v') = minimum [(c,u,v)| (u,v,c) <- as,
                                         u `elem` t, 
                                         v `elem` r]

-- 3ª definición de coste (con el algoritmo de Prim con conjuntos)
-- ===============================================================

coste3 :: Int -> Int
coste3 n = sum [p | (p,x,y) <- prim2 (grafoDivisibilidad n)]

-- (prim2 g) es el árbol de expansión mínimo del grafo g calculado
-- mediante el algoritmo de Prim. Por ejemplo,
--    λ> prim2 (grafoDivisibilidad 12)
--    [(11,1,11),(7,1,7),(2,5,10),(5,1,5),(3,3,9),(2,6,12),(2,3,6),
--     (3,1,3),(2,4,8),(2,2,4),(2,1,2)]
prim2 :: (Ix v, Num p, Ord p) => Grafo v p -> [(p,v,v)]
prim2 g = prim2' (S.singleton n)  -- Nodos colocados
                 (S.fromList ns)  -- Nodos por colocar 
                 []               -- Árbol de expansión
                 (aristas g)      -- Aristas del grafo
  where (n:ns) = nodos g

prim2' t r ae as
  | S.null r  = ae
  | otherwise = prim2' (S.insert v' t)
                       (S.delete v' r)
                       (e:ae)
                       as
  where e@(c,u', v') = minimum [(c,u,v)| (u,v,c) <- as,
                                         S.member u t, 
                                         S.member v r]

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

coste4 :: Int -> Int
coste4 n = sum [head (primeFactors x) | x <- [2..n]]

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

--    λ> coste1 400
--    14923
--    (0.08 secs, 31,336,440 bytes)
--    λ> coste2 400
--    14923
--    (4.54 secs, 220,745,608 bytes)
--    λ> coste3 400
--    14923
--    (0.69 secs, 217,031,144 bytes)
--    λ> coste4 400
--    14923
--    (0.01 secs, 2,192,336 bytes)
--    
--    λ> coste1 2000
--    284105
--    (2.09 secs, 842,601,904 bytes)
--    λ> coste4 2000
--    284105
--    (0.02 secs, 14,586,888 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

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

import Data.Ix

import Data.List (delete, sort)

import qualified Data.Set as S

import I1M.Grafo

import I1M.Tabla

import Data.Numbers.Primes (primeFactors)

-- Definición de grafoDivisibilidad

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

grafoDivisibilidad :: Int -> Grafo Int Int

grafoDivisibilidad n =

creaGrafo ND (1,n) [(x,y,y `div` x) | y <- [1..n]

, x <- [1..y-1]

, y `mod` x == 0]

-- 1ª definición de coste (con el algoritmo de Kruskal)

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

coste1 :: Int -> Int

coste1 n = sum [p | (p,x,y) <- kruskal (grafoDivisibilidad n)]

-- (kruskal g) es el árbol de expansión mínimo del grafo g calculado

-- mediante el algoritmo de Kruskal. Por ejemplo,

-- λ> kruskal (grafoDivisibilidad 12)

-- [(11,1,11),(7,1,7),(5,1,5),(3,3,9),(3,1,3),(2,6,12),(2,5,10),

-- (2,4,8),(2,3,6),(2,2,4),(2,1,2)]

kruskal :: (Ix v, Num p, Ord p) => Grafo v p -> [(p,v,v)]

kruskal g = kruskal' cola -- Cola ordenada

(tabla [(x,x) | x <- nodos g]) -- Tabla de raices

[] -- Árbol de expansión

(length (nodos g) - 1) -- Aristas por

-- colocar

where cola = sort [(p,x,y) | (x,y,p) <- aristas g]

kruskal' ((p,x,y):as) t ae n

| n == 0 = ae

| actualizado = kruskal' as t' ((p,x,y):ae) (n-1)

| otherwise = kruskal' as t ae n

where (actualizado,t') = buscaActualiza (x,y) t

-- (raiz t n) es la raíz de n en la tabla t. Por ejemplo,

-- raiz (crea [(1,1),(3,1),(4,3),(5,4),(2,6),(6,6)]) 5 == 1

-- raiz (crea [(1,1),(3,1),(4,3),(5,4),(2,6),(6,6)]) 2 == 6

raiz:: Eq n => Tabla n n -> n -> n

raiz t x | v == x = v

| otherwise = raiz t v

where v = valor t x

-- (buscaActualiza a t) es el par formado por False y la tabla t, si los

-- dos vértices de la arista a tienen la misma raíz en t y el par

-- formado por True y la tabla obtenida añadiéndole a t la arista

-- formada por el vértice de a de mayor raíz y la raíz del vértice de

-- a de menor raíz. Por ejemplo,

-- ghci> let t = crea [(1,1),(2,2),(3,1),(4,1)]

-- ghci> buscaActualiza (2,3) t

-- (True,Tbl [(1,1),(2,1),(3,1),(4,1)])

-- ghci> buscaActualiza (3,4) t

-- (False,Tbl [(1,1),(2,2),(3,1),(4,1)])

buscaActualiza :: (Eq n, Ord n) => (n,n) -> Tabla n n -> (Bool,Tabla n n)

buscaActualiza (x,y) t

| x' == y' = (False, t)

| y' < x' = (True, modifica (x,y') t)

| otherwise = (True, modifica (y,x') t)

where x' = raiz t x

y' = raiz t y

-- 2ª definición de coste (con el algoritmo de Prim)

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

coste2 :: Int -> Int

coste2 n = sum [p | (p,x,y) <- prim (grafoDivisibilidad n)]

-- (prim g) es el árbol de expansión mínimo del grafo g calculado

-- mediante el algoritmo de Prim. Por ejemplo,

-- λ> prim (grafoDivisibilidad 12)

-- [(11,1,11),(7,1,7),(2,5,10),(5,1,5),(3,3,9),(2,6,12),(2,3,6),

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

prim :: (Ix v, Num p, Ord p) => Grafo v p -> [(p,v,v)]

prim g = prim' [n] -- Nodos colocados

ns -- Nodos por colocar

[] -- Árbol de expansión

(aristas g) -- Aristas del grafo

where (n:ns) = nodos g

prim' t [] ae as = ae

prim' t r ae as = prim' (v':t) (delete v' r) (e:ae) as

where e@(c,u', v') = minimum [(c,u,v)| (u,v,c) <- as,

u `elem` t,

v `elem` r]

-- 3ª definición de coste (con el algoritmo de Prim con conjuntos)

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

coste3 :: Int -> Int

coste3 n = sum [p | (p,x,y) <- prim2 (grafoDivisibilidad n)]

-- (prim2 g) es el árbol de expansión mínimo del grafo g calculado

-- mediante el algoritmo de Prim. Por ejemplo,

-- λ> prim2 (grafoDivisibilidad 12)

-- [(11,1,11),(7,1,7),(2,5,10),(5,1,5),(3,3,9),(2,6,12),(2,3,6),

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

prim2 :: (Ix v, Num p, Ord p) => Grafo v p -> [(p,v,v)]

prim2 g = prim2' (S.singleton n) -- Nodos colocados

(S.fromList ns) -- Nodos por colocar

[] -- Árbol de expansión

(aristas g) -- Aristas del grafo

where (n:ns) = nodos g

prim2' t r ae as

| S.null r = ae

| otherwise = prim2' (S.insert v' t)

(S.delete v' r)

(e:ae)

where e@(c,u', v') = minimum [(c,u,v)| (u,v,c) <- as,

S.member u t,

S.member v r]

-- 4ª definición de coste

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

coste4 :: Int -> Int

coste4 n = sum [head (primeFactors x) | x <- [2..n]]

-- Comparación de eficiencia

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

-- λ> coste1 400

-- 14923

-- (0.08 secs, 31,336,440 bytes)

-- λ> coste2 400

-- 14923

-- (4.54 secs, 220,745,608 bytes)

-- λ> coste3 400

-- 14923

-- (0.69 secs, 217,031,144 bytes)

-- λ> coste4 400

-- 14923

-- (0.01 secs, 2,192,336 bytes)

-- λ> coste1 2000

-- 284105

-- (2.09 secs, 842,601,904 bytes)

-- λ> coste4 2000

-- 284105

-- (0.02 secs, 14,586,888 bytes)

[/schedule]

Sucesiones de listas de números

PorJosé A. Alonso 31-mayo-201926-marzo-2022

En la Olimpiada Internacional de Matemáticas del 2012 se propuso el siguiente problema:

Varios enteros positivos se escriben en una lista. Iterativamente, Alicia elige dos números adyacentes x e y tales que x > y y x está a la izquierda de y y reemplaza el par (x,y) por (y+1,x) o (x-1,x). Demostrar que sólo puede aplicar un número finito de dichas iteraciones.

Por ejemplo, las transformadas de la lista [1,3,2] son [1,2,3] y [1,3,3] y las dos obtenidas son finales (es decir, no se les puede aplicar ninguna transformación).

Definir las funciones

   soluciones :: [Int] -> [Estado]
   finales :: [Int] -> [[Int]]
   finalesMaximales :: [Int] -> (Int,[[Int]])

soluciones :: [Int] -> [Estado]

finales :: [Int] -> [[Int]]

finalesMaximales :: [Int] -> (Int,[[Int]])

tales que

(soluciones xs) es la lista de pares (n,ys) tales que ys es una lista final obtenida aplicándole n transformaciones a xs. Por ejemplo,

     λ> soluciones [1,3,2]
     [(1,[1,3,3]),(1,[1,2,3])]
     λ> sort (nub (soluciones [3,3,2]))
     [(1,[3,3,3]),(2,[2,3,3]),(2,[3,3,3])]
     λ> sort (nub (soluciones [3,2,1]))
     [(2,[2,2,3]),(3,[2,2,3]),(3,[2,3,3]),(3,[3,3,3]),(4,[2,3,3]),(4,[3,3,3])]

λ> soluciones [1,3,2]

[(1,[1,3,3]),(1,[1,2,3])]

λ> sort (nub (soluciones [3,3,2]))

[(1,[3,3,3]),(2,[2,3,3]),(2,[3,3,3])]

λ> sort (nub (soluciones [3,2,1]))

[(2,[2,2,3]),(3,[2,2,3]),(3,[2,3,3]),(3,[3,3,3]),(4,[2,3,3]),(4,[3,3,3])]

(finales xs) son las listas obtenidas transformando xs y a las que no se les puede aplicar más transformaciones. Por ejemplo,

     finales [1,2,3]               ==  [[1,2,3]]
     finales [1,3,2]               ==  [[1,2,3],[1,3,3]]
     finales [3,2,1]               ==  [[2,2,3],[2,3,3],[3,3,3]]
     finales [1,3,2,4]             ==  [[1,2,3,4],[1,3,3,4]]
     finales [1,3,2,3]             ==  [[1,2,3,3],[1,3,3,3]]
     length (finales [9,6,0,7,2])  ==  19
     length (finales [80,60..0])   ==  420

finales [1,2,3] == [[1,2,3]]

finales [1,3,2] == [[1,2,3],[1,3,3]]

finales [3,2,1] == [[2,2,3],[2,3,3],[3,3,3]]

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

finales [1,3,2,3] == [[1,2,3,3],[1,3,3,3]]

length (finales [9,6,0,7,2]) == 19

length (finales [80,60..0]) == 420

(finalesMaximales xs) es el par (n,yss) tal que la longitud de las cadenas más largas de transformaciones a partir de xs e yss es la lista de los estados finales a partir de xs con n transformaciones. Por ejemplo,

     finalesMaximales [9,5,7]   ==  (2,[[6,8,9],[8,8,9]])
     finalesMaximales [3,2,1]   ==  (4,[[2,3,3],[3,3,3]])
     finalesMaximales [3,2..0]  ==  (10,[[2,3,3,3],[3,3,3,3]])
     finalesMaximales [4,3..0]  ==  (20,[[3,4,4,4,4],[4,4,4,4,4]])

finalesMaximales [9,5,7] == (2,[[6,8,9],[8,8,9]])

finalesMaximales [3,2,1] == (4,[[2,3,3],[3,3,3]])

finalesMaximales [3,2..0] == (10,[[2,3,3,3],[3,3,3,3]])

finalesMaximales [4,3..0] == (20,[[3,4,4,4,4],[4,4,4,4,4]])

Soluciones

[schedule expon=’2019-06-07′ expat=»06:00″]

Las soluciones se pueden escribir en los comentarios hasta el 07 de junio.
El código se debe escribir entre una línea con <pre lang=»haskell»> y otra con </pre>

Pensamiento

Siempre que nos vemos
es cita para mañana.
Nunca nos encontraremos.

Antonio Machado

[/schedule]

[schedule on=’2019-06-07′ at=»06:00″]

import Data.List (nub, sort)
import I1M.BusquedaEnEspaciosDeEstados (buscaEE)

type Estado = (Int,[Int])

inicial :: [Int] -> Estado
inicial xs = (0,xs)

esFinal :: Estado -> Bool
esFinal e = null (sucesores e)

--    λ> sucesores [9,6,0,7,2]
--    [[7,9,0,7,2],[8,9,0,7,2],[9,1,6,7,2],[9,5,6,7,2],[9,6,0,3,7],[9,6,0,6,7]]
sucesores :: Estado -> [Estado]
sucesores (_,[])  = []
sucesores (_,[_]) = []
sucesores (n,x:y:xs)
  | x > y     = [(n+1,y+1:x:xs), (n+1,x-1:x:xs)] ++ yss
  | otherwise = yss
  where yss = [(m,x:ys) | (m,ys) <- sucesores (n,y:xs)]
                       
soluciones :: [Int] -> [Estado]
soluciones xs =
  buscaEE sucesores esFinal (inicial xs)

finales :: [Int] -> [[Int]]
finales xs =
  sort (nub (map snd (soluciones xs)))
            
finalesMaximales :: [Int] -> (Int,[[Int]])
finalesMaximales xs =
  (m, [xs | (n,xs) <- es, n == m])
  where es    = sort (nub (soluciones xs))
        (m,_) = maximum es

import Data.List (nub, sort)

import I1M.BusquedaEnEspaciosDeEstados (buscaEE)

type Estado = (Int,[Int])

inicial :: [Int] -> Estado

inicial xs = (0,xs)

esFinal :: Estado -> Bool

esFinal e = null (sucesores e)

-- λ> sucesores [9,6,0,7,2]

-- [[7,9,0,7,2],[8,9,0,7,2],[9,1,6,7,2],[9,5,6,7,2],[9,6,0,3,7],[9,6,0,6,7]]

sucesores :: Estado -> [Estado]

sucesores (_,[]) = []

sucesores (_,[_]) = []

sucesores (n,x:y:xs)

| x > y = [(n+1,y+1:x:xs), (n+1,x-1:x:xs)] ++ yss

| otherwise = yss

where yss = [(m,x:ys) | (m,ys) <- sucesores (n,y:xs)]

soluciones :: [Int] -> [Estado]

soluciones xs =

buscaEE sucesores esFinal (inicial xs)

finales :: [Int] -> [[Int]]

finales xs =

sort (nub (map snd (soluciones xs)))

finalesMaximales :: [Int] -> (Int,[[Int]])

finalesMaximales xs =

(m, [xs | (n,xs) <- es, n == m])

where es = sort (nub (soluciones xs))

(m,_) = maximum es

[/schedule]

Caminos en un grafo

PorJosé A. Alonso 30-mayo-201926-marzo-2022

Definir las funciones

   grafo   :: [(Int,Int)] -> Grafo Int Int
   caminos :: Grafo Int Int -> Int -> Int -> [[Int]]

1 2	grafo :: [(Int,Int)] -> Grafo Int Int caminos :: Grafo Int Int -> Int -> Int -> [[Int]]

tales que

(grafo as) es el grafo no dirigido definido cuyas aristas son as. Por ejemplo,

     ghci> grafo [(2,4),(4,5)]
     G ND (array (2,5) [(2,[(4,0)]),(3,[]),(4,[(2,0),(5,0)]),(5,[(4,0)])])

1 2	ghci> grafo [(2,4),(4,5)] G ND (array (2,5) [(2,[(4,0)]),(3,[]),(4,[(2,0),(5,0)]),(5,[(4,0)])])

(caminos g a b) es la lista los caminos en el grafo g desde a hasta b sin pasar dos veces por el mismo nodo. Por ejemplo,

     ghci> sort (caminos (grafo [(1,3),(2,5),(3,5),(3,7),(5,7)]) 1 7)
     [[1,3,5,7],[1,3,7]]
     ghci> sort (caminos (grafo [(1,3),(2,5),(3,5),(3,7),(5,7)]) 2 7)
     [[2,5,3,7],[2,5,7]]
     ghci> sort (caminos (grafo [(1,3),(2,5),(3,5),(3,7),(5,7)]) 1 2)
     [[1,3,5,2],[1,3,7,5,2]]
     ghci> caminos (grafo [(1,3),(2,5),(3,5),(3,7),(5,7)]) 1 4
     []
     ghci> length (caminos (grafo [(i,j) | i <- [1..10], j <- [i..10]]) 1 10)
     109601

ghci> sort (caminos (grafo [(1,3),(2,5),(3,5),(3,7),(5,7)]) 1 7)

[[1,3,5,7],[1,3,7]]

ghci> sort (caminos (grafo [(1,3),(2,5),(3,5),(3,7),(5,7)]) 2 7)

[[2,5,3,7],[2,5,7]]

ghci> sort (caminos (grafo [(1,3),(2,5),(3,5),(3,7),(5,7)]) 1 2)

[[1,3,5,2],[1,3,7,5,2]]

ghci> caminos (grafo [(1,3),(2,5),(3,5),(3,7),(5,7)]) 1 4

[]

ghci> length (caminos (grafo [(i,j) | i <- [1..10], j <- [i..10]]) 1 10)

109601

Soluciones

[schedule expon=’2019-06-06′ expat=»06:00″]

Las soluciones se pueden escribir en los comentarios hasta el 06 de junio.
El código se debe escribir entre una línea con <pre lang=»haskell»> y otra con </pre>

Pensamiento

Tengo dentro de un herbario
una tarde disecada,
lila, violeta y dorada.
Caprichos de solitario.

Antonio Machado

[/schedule]

[schedule on=’2019-06-06′ at=»06:00″]

import Data.List (sort)
import I1M.Grafo
import I1M.BusquedaEnEspaciosDeEstados

grafo :: [(Int,Int)] -> Grafo Int Int
grafo as = creaGrafo ND (m,n) [(x,y,0) | (x,y) <- as]
  where ns = map fst as ++ map snd as
        m  = minimum ns
        n  = maximum ns

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

caminos :: Grafo Int Int -> Int -> Int -> [[Int]]
caminos g a b = aux [[b]] where 
  aux [] = []
  aux ((x:xs):yss)
    | x == a    = (x:xs) : aux yss
    | otherwise = aux ([z:x:xs | z <- adyacentes g x
                               , z `notElem` (x:xs)] 
                       ++ yss) 

-- 2ª solución (mediante espacio de estados)
-- =========================================

caminos2 :: Grafo Int Int -> Int -> Int -> [[Int]]
caminos2 g a b = buscaEE sucesores esFinal inicial
  where inicial          = [b]
        sucesores (x:xs) = [z:x:xs | z <- adyacentes g x
                                   , z `notElem` (x:xs)] 
        esFinal (x:xs)   = x == a

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

--    ghci> length (caminos (grafo [(i,j) | i <- [1..10], j <- [i..10]]) 1 10)
--    109601
--    (3.57 secs, 500533816 bytes)
--    ghci> length (caminos2 (grafo [(i,j) | i <- [1..10], j <- [i..10]]) 1 10)
--    109601
--    (3.53 secs, 470814096 bytes)

import Data.List (sort)

import I1M.Grafo

import I1M.BusquedaEnEspaciosDeEstados

grafo :: [(Int,Int)] -> Grafo Int Int

grafo as = creaGrafo ND (m,n) [(x,y,0) | (x,y) <- as]

where ns = map fst as ++ map snd as

m = minimum ns

n = maximum ns

-- 1ª solución

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

caminos :: Grafo Int Int -> Int -> Int -> [[Int]]

caminos g a b = aux [[b]] where

aux [] = []

aux ((x:xs):yss)

| x == a = (x:xs) : aux yss

| otherwise = aux ([z:x:xs | z <- adyacentes g x

, z `notElem` (x:xs)]

++ yss)

-- 2ª solución (mediante espacio de estados)

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

caminos2 :: Grafo Int Int -> Int -> Int -> [[Int]]

caminos2 g a b = buscaEE sucesores esFinal inicial

where inicial = [b]

sucesores (x:xs) = [z:x:xs | z <- adyacentes g x

, z `notElem` (x:xs)]

esFinal (x:xs) = x == a

-- Comparación de eficiencia

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

-- ghci> length (caminos (grafo [(i,j) | i <- [1..10], j <- [i..10]]) 1 10)

-- 109601

-- (3.57 secs, 500533816 bytes)

-- ghci> length (caminos2 (grafo [(i,j) | i <- [1..10], j <- [i..10]]) 1 10)

-- 109601

-- (3.53 secs, 470814096 bytes)

[/schedule]

Número de triangulaciones de un polígono

PorJosé A. Alonso 29-mayo-201928-mayo-2019

Una triangulación de un polígono es una división del área en un conjunto de triángulos, de forma que la unión de todos ellos es igual al polígono original, y cualquier par de triángulos es disjunto o comparte únicamente un vértice o un lado. En el caso de polígonos convexos, la cantidad de triangulaciones posibles depende únicamente del número de vértices del polígono.

Si llamamos T(n) al número de triangulaciones de un polígono de n vértices, se verifica la siguiente relación de recurrencia:

    T(2) = 1
    T(n) = T(2)*T(n-1) + T(3)*T(n-2) + ... + T(n-1)*T(2)

1 2	T(2) = 1 T(n) = T(2)T(n-1) + T(3)T(n-2) + ... + T(n-1)*T(2)

Definir la función

   numeroTriangulaciones :: Integer -> Integer

1	numeroTriangulaciones :: Integer -> Integer

tal que (numeroTriangulaciones n) es el número de triangulaciones de un polígono convexo de n vértices. Por ejemplo,

   numeroTriangulaciones 3  == 1
   numeroTriangulaciones 5  == 5
   numeroTriangulaciones 6  == 14
   numeroTriangulaciones 7  == 42
   numeroTriangulaciones 50 == 131327898242169365477991900
   length (show (numeroTriangulaciones   800)) ==  476
   length (show (numeroTriangulaciones  1000)) ==  597
   length (show (numeroTriangulaciones 10000)) == 6014

numeroTriangulaciones 3 == 1

numeroTriangulaciones 5 == 5

numeroTriangulaciones 6 == 14

numeroTriangulaciones 7 == 42

numeroTriangulaciones 50 == 131327898242169365477991900

length (show (numeroTriangulaciones 800)) == 476

length (show (numeroTriangulaciones 1000)) == 597

length (show (numeroTriangulaciones 10000)) == 6014

Soluciones

[schedule expon=’2019-06-05′ expat=»06:00″]

Las soluciones se pueden escribir en los comentarios hasta el 05 de junio.
El código se debe escribir entre una línea con <pre lang=»haskell»> y otra con </pre>

Pensamiento

No es la belleza el gran incentivo del amor, sino la sed metafísica de lo esencialmente otro.

Antonio Machado

[/schedule]

[schedule on=’2019-06-05′ at=»06:00″]

import Data.Array

import Data.Array (Array, (!), array)
import Data.List  (genericIndex)
import qualified Data.Vector as V

-- 1ª solución (por recursión)
-- ===========================

numeroTriangulaciones :: Integer -> Integer
numeroTriangulaciones 2 = 1
numeroTriangulaciones n = sum (zipWith (*) ts (reverse ts))
  where ts = [numeroTriangulaciones k | k <- [2..n-1]]

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

--    λ> map numeroTriangulaciones2 [2..15]
--    [1,1,2,5,14,42,132,429,1430,4862,16796,58786,208012,742900]
numeroTriangulaciones2 :: Integer -> Integer
numeroTriangulaciones2 n = 
  head (sucNumeroTriangulacionesInversas `genericIndex` (n-2))

--    λ> mapM_ print (take 10 sucNumeroTriangulacionesInversas)
--    [1]
--    [1,1]
--    [2,1,1]
--    [5,2,1,1]
--    [14,5,2,1,1]
--    [42,14,5,2,1,1]
--    [132,42,14,5,2,1,1]
--    [429,132,42,14,5,2,1,1]
--    [1430,429,132,42,14,5,2,1,1]
--    [4862,1430,429,132,42,14,5,2,1,1]
sucNumeroTriangulacionesInversas :: [[Integer]]        
sucNumeroTriangulacionesInversas = iterate f [1]
  where f ts = sum (zipWith (*) ts (reverse ts)) : ts

-- 3ª solución (con programación dinámica)
-- =======================================

numeroTriangulaciones3 :: Integer -> Integer
numeroTriangulaciones3 n = vectorTriang n ! n

--    λ> vectorTriang 9
--    array (2,9) [(2,1),(3,1),(4,2),(5,5),(6,14),(7,42),(8,132),(9,429)]
vectorTriang :: Integer -> Array Integer Integer
vectorTriang n = v
  where v = array (2,n) [(i, f i) | i <-[2..n]]
        f 2 = 1
        f i = sum [v!j*v!(i-j+1) | j <-[2..i-1]]

-- 4ª solución (con los números de Catalan)
-- ========================================

-- Al calcular por primeros números de triangulaciones se obtiene
--    λ> map numeroTriangulaciones [2..12]
--    [1,1,2,5,14,42,132,429,1430,4862,16796]
-- Se observa que se corresponden con los números de Catalan
-- http://bit.ly/2FOc1S1
-- 
-- El n-ésimo número de Catalan es
--    (2n)! / (n! * (n+1)!)
-- El número de triangulaciones de un polígono de n lados es el
-- (n-2)-ésimo número de Catalan.

numeroTriangulaciones4 :: Integer -> Integer
numeroTriangulaciones4 n = numeroCatalan (n-2) 

numeroCatalan :: Integer -> Integer
numeroCatalan n =
  factorial (2*n) `div` (factorial (n+1) * factorial n)

factorial :: Integer -> Integer
factorial n = product [1..n]

-- 5ª solución
-- ===========

numeroTriangulaciones5 :: Integer -> Integer
numeroTriangulaciones5 n = v V.! (m-2)
   where v = V.constructN m
           (\w -> if   V.null w then 1
                  else V.sum (V.zipWith (*) w (V.reverse w)))
         m = fromIntegral n

-- 6ª solución
-- ===========

numeroTriangulaciones6 :: Integer -> Integer
numeroTriangulaciones6 n = nCr (2*n-4, n-2) `div` (n-1)
  where nCr (n,m)   = factorial n `div` (factorial (n-m) * factorial m)
        factorial n = product [1..n]

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

--    λ> numeroTriangulaciones 22
--    6564120420
--    (3.97 secs, 668,070,936 bytes)
--    λ> numeroTriangulaciones2 22
--    6564120420
--    (0.01 secs, 180,064 bytes)
--    λ> numeroTriangulaciones3 22
--    6564120420
--    (0.01 secs, 285,792 bytes)
--    
--    λ> length (show (numeroTriangulaciones2 800))
--    476
--    (0.59 secs, 125,026,824 bytes)
--    λ> length (show (numeroTriangulaciones3 800))
--    476
--    (1.95 secs, 334,652,936 bytes)
--    λ> length (show (numeroTriangulaciones4 800))
--    476
--    (0.01 secs, 2,960,088 bytes)
--    λ> length (show (numeroTriangulaciones5 800))
--    476
--    (0.65 secs, 200,415,640 bytes)
--    λ> length (show (numeroTriangulaciones6 800))
--    476
--    (0.01 secs, 2,960,224 bytes)
--    
--    λ> length (show (numeroTriangulaciones4 (10^4)))
--    6014
--    (1.80 secs, 542,364,320 bytes)
--    λ> length (show (numeroTriangulaciones6 (10^4)))
--    6014
--    (1.87 secs, 542,351,136 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

124

125

126

127

128

129

import Data.Array

import Data.Array (Array, (!), array)

import Data.List (genericIndex)

import qualified Data.Vector as V

-- 1ª solución (por recursión)

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

numeroTriangulaciones :: Integer -> Integer

numeroTriangulaciones 2 = 1

numeroTriangulaciones n = sum (zipWith (*) ts (reverse ts))

where ts = [numeroTriangulaciones k | k <- [2..n-1]]

-- 2ª solución

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

-- λ> map numeroTriangulaciones2 [2..15]

-- [1,1,2,5,14,42,132,429,1430,4862,16796,58786,208012,742900]

numeroTriangulaciones2 :: Integer -> Integer

numeroTriangulaciones2 n =

head (sucNumeroTriangulacionesInversas `genericIndex` (n-2))

-- λ> mapM_ print (take 10 sucNumeroTriangulacionesInversas)

-- [1]

-- [1,1]

-- [2,1,1]

-- [5,2,1,1]

-- [14,5,2,1,1]

-- [42,14,5,2,1,1]

-- [132,42,14,5,2,1,1]

-- [429,132,42,14,5,2,1,1]

-- [1430,429,132,42,14,5,2,1,1]

-- [4862,1430,429,132,42,14,5,2,1,1]

sucNumeroTriangulacionesInversas :: [[Integer]]

sucNumeroTriangulacionesInversas = iterate f [1]

where f ts = sum (zipWith (*) ts (reverse ts)) : ts

-- 3ª solución (con programación dinámica)

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

numeroTriangulaciones3 :: Integer -> Integer

numeroTriangulaciones3 n = vectorTriang n ! n

-- λ> vectorTriang 9

-- array (2,9) [(2,1),(3,1),(4,2),(5,5),(6,14),(7,42),(8,132),(9,429)]

vectorTriang :: Integer -> Array Integer Integer

vectorTriang n = v

where v = array (2,n) [(i, f i) | i <-[2..n]]

f 2 = 1

f i = sum [v!j*v!(i-j+1) | j <-[2..i-1]]

-- 4ª solución (con los números de Catalan)

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

-- Al calcular por primeros números de triangulaciones se obtiene

-- λ> map numeroTriangulaciones [2..12]

-- [1,1,2,5,14,42,132,429,1430,4862,16796]

-- Se observa que se corresponden con los números de Catalan

-- http://bit.ly/2FOc1S1

-- El n-ésimo número de Catalan es

-- (2n)! / (n! * (n+1)!)

-- El número de triangulaciones de un polígono de n lados es el

-- (n-2)-ésimo número de Catalan.

numeroTriangulaciones4 :: Integer -> Integer

numeroTriangulaciones4 n = numeroCatalan (n-2)

numeroCatalan :: Integer -> Integer

numeroCatalan n =

factorial (2*n) `div` (factorial (n+1) * factorial n)

factorial :: Integer -> Integer

factorial n = product [1..n]

-- 5ª solución

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

numeroTriangulaciones5 :: Integer -> Integer

numeroTriangulaciones5 n = v V.! (m-2)

where v = V.constructN m

(\w -> if V.null w then 1

else V.sum (V.zipWith (*) w (V.reverse w)))

m = fromIntegral n

-- 6ª solución

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

numeroTriangulaciones6 :: Integer -> Integer

numeroTriangulaciones6 n = nCr (2*n-4, n-2) `div` (n-1)

where nCr (n,m) = factorial n `div` (factorial (n-m) * factorial m)

factorial n = product [1..n]

-- Comparación de eficiencia

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

-- λ> numeroTriangulaciones 22

-- 6564120420

-- (3.97 secs, 668,070,936 bytes)

-- λ> numeroTriangulaciones2 22

-- 6564120420

-- (0.01 secs, 180,064 bytes)

-- λ> numeroTriangulaciones3 22

-- 6564120420

-- (0.01 secs, 285,792 bytes)

-- λ> length (show (numeroTriangulaciones2 800))

-- 476

-- (0.59 secs, 125,026,824 bytes)

-- λ> length (show (numeroTriangulaciones3 800))

-- 476

-- (1.95 secs, 334,652,936 bytes)

-- λ> length (show (numeroTriangulaciones4 800))

-- 476

-- (0.01 secs, 2,960,088 bytes)

-- λ> length (show (numeroTriangulaciones5 800))

-- 476

-- (0.65 secs, 200,415,640 bytes)

-- λ> length (show (numeroTriangulaciones6 800))

-- 476

-- (0.01 secs, 2,960,224 bytes)

-- λ> length (show (numeroTriangulaciones4 (10^4)))

-- 6014

-- (1.80 secs, 542,364,320 bytes)

-- λ> length (show (numeroTriangulaciones6 (10^4)))

-- 6014

-- (1.87 secs, 542,351,136 bytes)

[/schedule]

Espacio de estados del problema de las N reinas

PorJosé A. Alonso 28-mayo-201925-abril-2021

El problema de las N reinas consiste en colocar N reinas en tablero rectangular de dimensiones N por N de forma que no se encuentren más de una en la misma línea: horizontal, vertical o diagonal. Por ejemplo, una solución para el problema de las 4 reinas es

   |---|---|---|---|
   |   | R |   |   |
   |---|---|---|---|
   |   |   |   | R |
   |---|---|---|---|
   | R |   |   |   |
   |---|---|---|---|
   |   |   | R |   |
   |---|---|---|---|

|---|---|---|---|

| | R | | |

|---|---|---|---|

| | | | R |

|---|---|---|---|

| R | | | |

|---|---|---|---|

| | | R | |

|---|---|---|---|

Los estados del problema de las N reinas son los tableros con las reinas colocadas. Inicialmente el tablero está vacío y, en cda paso se coloca una reina en la primera columna en la que aún no hay ninguna reina.

Cada estado se representa por una lista de números que indican las filas donde se han colocado las reinas. Por ejemplo, el tablero anterior se representa por [2,4,1,3].

Usando la librería de árboles Data.Tree, definir las funciones

   arbolReinas :: Int -> Tree [Int]
   nEstados    :: Int -> Int
   soluciones  :: Int -> [[Int]]
   nSoluciones :: Int -> Int

arbolReinas :: Int -> Tree [Int]

nEstados :: Int -> Int

soluciones :: Int -> [[Int]]

nSoluciones :: Int -> Int

tales que

(arbolReinas n) es el árbol de estados para el problema de las n reinas. Por ejemplo,

     λ> putStrLn (drawTree (fmap show (arbolReinas 4)))
     []
     |
     +- [1]
     |  |
     |  +- [3,1]
     |  |
     |  `- [4,1]
     |     |
     |     `- [2,4,1]
     |
     +- [2]
     |  |
     |  `- [4,2]
     |     |
     |     `- [1,4,2]
     |        |
     |        `- [3,1,4,2]
     |
     +- [3]
     |  |
     |  `- [1,3]
     |     |
     |     `- [4,1,3]
     |        |
     |        `- [2,4,1,3]
     |
     `- [4]
        |
        +- [1,4]
        |  |
        |  `- [3,1,4]
        |
        `- [2,4]
     
     λ> putStrLn (drawTree (fmap show (arbolReinas 5)))
     []
     |
     +- [1]
     |  |
     |  +- [3,1]
     |  |  |
     |  |  `- [5,3,1]
     |  |     |
     |  |     `- [2,5,3,1]
     |  |        |
     |  |        `- [4,2,5,3,1]
     |  |
     |  +- [4,1]
     |  |  |
     |  |  `- [2,4,1]
     |  |     |
     |  |     `- [5,2,4,1]
     |  |        |
     |  |        `- [3,5,2,4,1]
     |  |
     |  `- [5,1]
     |     |
     |     `- [2,5,1]
     |
     +- [2]
     |  |
     |  +- [4,2]
     |  |  |
     |  |  `- [1,4,2]
     |  |     |
     |  |     `- [3,1,4,2]
     |  |        |
     |  |        `- [5,3,1,4,2]
     |  |
     |  `- [5,2]
     |     |
     |     +- [1,5,2]
     |     |  |
     |     |  `- [4,1,5,2]
     |     |
     |     `- [3,5,2]
     |        |
     |        `- [1,3,5,2]
     |           |
     |           `- [4,1,3,5,2]
     |
     +- [3]
     |  |
     |  +- [1,3]
     |  |  |
     |  |  `- [4,1,3]
     |  |     |
     |  |     `- [2,4,1,3]
     |  |        |
     |  |        `- [5,2,4,1,3]
     |  |
     |  `- [5,3]
     |     |
     |     `- [2,5,3]
     |        |
     |        `- [4,2,5,3]
     |           |
     |           `- [1,4,2,5,3]
     |
     +- [4]
     |  |
     |  +- [1,4]
     |  |  |
     |  |  +- [3,1,4]
     |  |  |  |
     |  |  |  `- [5,3,1,4]
     |  |  |     |
     |  |  |     `- [2,5,3,1,4]
     |  |  |
     |  |  `- [5,1,4]
     |  |     |
     |  |     `- [2,5,1,4]
     |  |
     |  `- [2,4]
     |     |
     |     `- [5,2,4]
     |        |
     |        `- [3,5,2,4]
     |           |
     |           `- [1,3,5,2,4]
     |
     `- [5]
        |
        +- [1,5]
        |  |
        |  `- [4,1,5]
        |
        +- [2,5]
        |  |
        |  `- [4,2,5]
        |     |
        |     `- [1,4,2,5]
        |        |
        |        `- [3,1,4,2,5]
        |
        `- [3,5]
           |
           `- [1,3,5]
              |
              `- [4,1,3,5]
                 |
                 `- [2,4,1,3,5]

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

λ> putStrLn (drawTree (fmap show (arbolReinas 4)))

[]

+- [1]

| |

| +- [3,1]

| |

| `- [4,1]

| |

| `- [2,4,1]

+- [2]

| |

| `- [4,2]

| |

| `- [1,4,2]

| |

| `- [3,1,4,2]

+- [3]

| |

| `- [1,3]

| |

| `- [4,1,3]

| |

| `- [2,4,1,3]

`- [4]

+- [1,4]

| |

| `- [3,1,4]

`- [2,4]

λ> putStrLn (drawTree (fmap show (arbolReinas 5)))

[]

+- [1]

| |

| +- [3,1]

| | |

| | `- [5,3,1]

| | |

| | `- [2,5,3,1]

| | |

| | `- [4,2,5,3,1]

| |

| +- [4,1]

| | |

| | `- [2,4,1]

| | |

| | `- [5,2,4,1]

| | |

| | `- [3,5,2,4,1]

| |

| `- [5,1]

| |

| `- [2,5,1]

+- [2]

| |

| +- [4,2]

| | |

| | `- [1,4,2]

| | |

| | `- [3,1,4,2]

| | |

| | `- [5,3,1,4,2]

| |

| `- [5,2]

| |

| +- [1,5,2]

| | |

| | `- [4,1,5,2]

| |

| `- [3,5,2]

| |

| `- [1,3,5,2]

| |

| `- [4,1,3,5,2]

+- [3]

| |

| +- [1,3]

| | |

| | `- [4,1,3]

| | |

| | `- [2,4,1,3]

| | |

| | `- [5,2,4,1,3]

| |

| `- [5,3]

| |

| `- [2,5,3]

| |

| `- [4,2,5,3]

| |

| `- [1,4,2,5,3]

+- [4]

| |

| +- [1,4]

| | |

| | +- [3,1,4]

| | | |

| | | `- [5,3,1,4]

| | | |

| | | `- [2,5,3,1,4]

| | |

| | `- [5,1,4]

| | |

| | `- [2,5,1,4]

| |

| `- [2,4]

| |

| `- [5,2,4]

| |

| `- [3,5,2,4]

| |

| `- [1,3,5,2,4]

`- [5]

+- [1,5]

| |

| `- [4,1,5]

+- [2,5]

| |

| `- [4,2,5]

| |

| `- [1,4,2,5]

| |

| `- [3,1,4,2,5]

`- [3,5]

`- [1,3,5]

`- [4,1,3,5]

`- [2,4,1,3,5]

(nEstados n) es el número de estados en el problema de las n reinas. Por ejemplo,

     nEstados 4            ==  17
     nEstados 5            ==  54
     map nEstados [0..10]  ==  [1,2,3,6,17,54,153,552,2057,8394,35539]

nEstados 4 == 17

nEstados 5 == 54

map nEstados [0..10] == [1,2,3,6,17,54,153,552,2057,8394,35539]

(soluciones n) es la lista de estados que son soluciones del problema de las n reinas. Por ejemplo,

     λ> soluciones 4
     [[3,1,4,2],[2,4,1,3]]
     λ> soluciones 5
     [[4,2,5,3,1],[3,5,2,4,1],[5,3,1,4,2],[4,1,3,5,2],[5,2,4,1,3],
      [1,4,2,5,3],[2,5,3,1,4],[1,3,5,2,4],[3,1,4,2,5],[2,4,1,3,5]]

λ> soluciones 4

[[3,1,4,2],[2,4,1,3]]

λ> soluciones 5

[[4,2,5,3,1],[3,5,2,4,1],[5,3,1,4,2],[4,1,3,5,2],[5,2,4,1,3],

[1,4,2,5,3],[2,5,3,1,4],[1,3,5,2,4],[3,1,4,2,5],[2,4,1,3,5]]

(nSoluciones n) es el número de soluciones del problema de las n reinas. Por ejemplo,

     nSoluciones 4            ==  2
     nSoluciones 5            ==  10
     map nSoluciones [0..10]  ==  [1,1,0,0,2,10,4,40,92,352,724]

nSoluciones 4 == 2

nSoluciones 5 == 10

map nSoluciones [0..10] == [1,1,0,0,2,10,4,40,92,352,724]

Soluciones

[schedule expon=’2019-06-04′ expat=»06:00″]

Las soluciones se pueden escribir en los comentarios hasta el 04 de junio.
El código se debe escribir entre una línea con <pre lang=»haskell»> y otra con </pre>

Pensamiento

Ya algunos pedagogos comienzan a comprender que los niños no deben ser educados como meros aprendices de hombre, que hay algo sagrado en la infancia para vivir plenamente por ella.

Antonio Machado

[/schedule]

[schedule on=’2019-06-04′ at=»06:00″]

import Data.List ((\\))
import Data.Tree

-- Definición de arbolReinas
-- =========================

arbolReinas :: Int -> Tree [Int]
arbolReinas n = expansion n []
  where
    expansion m xs = Node xs [expansion (m-1) ys | ys <- sucesores n xs]

-- (sucesores n xs) es la lista de los sucesores del estado xs en el
-- problema de las n reinas. Por ejemplo,
--    sucesores 4 []       ==  [[1],[2],[3],[4]]
--    sucesores 4 [1]      ==  [[3,1],[4,1]]
--    sucesores 4 [4,1]    ==  [[2,4,1]]
--    sucesores 4 [2,4,1]  ==  []
sucesores :: Int -> [Int] -> [[Int]]
sucesores n xs = [y:xs | y <- [1..n] \\ xs
                       , noAtaca y xs 1]

-- (noAtaca y xs d) se verifica si la reina en la fila y no ataca a las
-- colocadas en las filas xs donde d es el número de columnas desde la
-- de la posición de x a la primera de xs.
noAtaca :: Int -> [Int] -> Int -> Bool
noAtaca _ [] _ = True
noAtaca y (x:xs) distH = abs(y-x) /= distH &&
                         noAtaca y xs (distH + 1)               

-- Definición de nEstados
-- ======================

nEstados :: Int -> Int
nEstados = length . arbolReinas

-- Definición de solucionesReinas
-- ==============================

--    λ> soluciones 4
--    [[3,1,4,2],[2,4,1,3]]
--    λ> soluciones 5
--    [[4,2,5,3,1],[3,5,2,4,1],[5,3,1,4,2],[4,1,3,5,2],[5,2,4,1,3],
--     [1,4,2,5,3],[2,5,3,1,4],[1,3,5,2,4],[3,1,4,2,5],[2,4,1,3,5]]
soluciones :: Int -> [[Int]]
soluciones n =
  filter (\xs -> length xs == n) (estados n)

-- (estados n) es la lista de estados del problema de las n reinas. Por
-- ejemplo, 
--   λ> estados 4
--   [[],
--    [1],[2],[3],[4],
--    [3,1],[4,1],[4,2],[1,3],[1,4],[2,4],
--    [2,4,1],[1,4,2],[4,1,3],[3,1,4],
--    [3,1,4,2],[2,4,1,3]]
estados :: Int -> [[Int]]
estados = concat . levels . arbolReinas

-- Definición de nSoluciones
-- =========================

nSoluciones :: Int -> Int
nSoluciones = length . soluciones

import Data.List ((\\))

import Data.Tree

-- Definición de arbolReinas

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

arbolReinas :: Int -> Tree [Int]

arbolReinas n = expansion n []

where

expansion m xs = Node xs [expansion (m-1) ys | ys <- sucesores n xs]

-- (sucesores n xs) es la lista de los sucesores del estado xs en el

-- problema de las n reinas. Por ejemplo,

-- sucesores 4 [] == [[1],[2],[3],[4]]

-- sucesores 4 [1] == [[3,1],[4,1]]

-- sucesores 4 [4,1] == [[2,4,1]]

-- sucesores 4 [2,4,1] == []

sucesores :: Int -> [Int] -> [[Int]]

sucesores n xs = [y:xs | y <- [1..n] \\ xs

, noAtaca y xs 1]

-- (noAtaca y xs d) se verifica si la reina en la fila y no ataca a las

-- colocadas en las filas xs donde d es el número de columnas desde la

-- de la posición de x a la primera de xs.

noAtaca :: Int -> [Int] -> Int -> Bool

noAtaca _ [] _ = True

noAtaca y (x:xs) distH = abs(y-x) /= distH &&

noAtaca y xs (distH + 1)

-- Definición de nEstados

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

nEstados :: Int -> Int

nEstados = length . arbolReinas

-- Definición de solucionesReinas

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

-- λ> soluciones 4

-- [[3,1,4,2],[2,4,1,3]]

-- λ> soluciones 5

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

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

soluciones :: Int -> [[Int]]

soluciones n =

filter (\xs -> length xs == n) (estados n)

-- (estados n) es la lista de estados del problema de las n reinas. Por

-- ejemplo,

-- λ> estados 4

-- [[],

-- [1],[2],[3],[4],

-- [3,1],[4,1],[4,2],[1,3],[1,4],[2,4],

-- [2,4,1],[1,4,2],[4,1,3],[3,1,4],

-- [3,1,4,2],[2,4,1,3]]

estados :: Int -> [[Int]]

estados = concat . levels . arbolReinas

-- Definición de nSoluciones

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

nSoluciones :: Int -> Int

nSoluciones = length . soluciones

[/schedule]

El problema de las N torres

PorJosé A. Alonso 27-mayo-201926-mayo-2019

El problema de las N torres consiste en colocar N torres en un tablero con N filas y N columnas de forma que no haya dos torres en la misma fila ni en la misma columna.

Cada solución del problema de puede representar mediante una matriz con ceros y unos donde los unos representan las posiciones ocupadas por las torres y los ceros las posiciones libres. Por ejemplo,

   ( 0 1 0 )
   ( 1 0 0 )
   ( 0 0 1 )

( 0 1 0 )

( 1 0 0 )

( 0 0 1 )

representa una solución del problema de las 3 torres.

Definir las funciones

   torres  :: Int -> [Matrix Int]
   nTorres :: Int -> Integer

1 2	torres :: Int -> [Matrix Int] nTorres :: Int -> Integer

tales que

(torres n) es la lista de las soluciones del problema de las n torres. Por ejemplo,

      λ> torres 3
      [( 1 0 0 )
       ( 0 1 0 )
       ( 0 0 1 )
      ,( 1 0 0 )
       ( 0 0 1 )
       ( 0 1 0 )
      ,( 0 1 0 )
       ( 1 0 0 )
       ( 0 0 1 )
      ,( 0 1 0 )
       ( 0 0 1 )
       ( 1 0 0 )
      ,( 0 0 1 )
       ( 1 0 0 )
       ( 0 1 0 )
      ,( 0 0 1 )
       ( 0 1 0 )
       ( 1 0 0 )
      ]

λ> torres 3

[( 1 0 0 )

( 0 1 0 )

( 0 0 1 )

,( 1 0 0 )

( 0 0 1 )

( 0 1 0 )

,( 0 1 0 )

( 1 0 0 )

( 0 0 1 )

,( 0 1 0 )

( 0 0 1 )

( 1 0 0 )

,( 0 0 1 )

( 1 0 0 )

( 0 1 0 )

,( 0 0 1 )

( 0 1 0 )

( 1 0 0 )

]

donde se ha indicado con 1 las posiciones ocupadas por las torres.

(nTorres n) es el número de soluciones del problema de las n torres. Por ejemplo,

      λ> nTorres 3
      6
      λ> length (show (nTorres (10^4)))
      35660

λ> nTorres 3

λ> length (show (nTorres (10^4)))

35660

Soluciones

[schedule expon=’2019-06-03′ expat=»06:00″]

Las soluciones se pueden escribir en los comentarios hasta el 03 de junio.
El código se debe escribir entre una línea con <pre lang=»haskell»> y otra con </pre>

Pensamiento

Nubes, sol, prado verde y caserío \\
en la loma revueltos. Primavera \\
puso en el aire de este campo frío \\
la gracia de sus chopos de ribera.

Antonio Machado

[/schedule]

[schedule on=’2019-06-03′ at=»06:00″]

import Data.List (genericLength, sort, permutations)
import Data.Matrix 

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

torres1 :: Int -> [Matrix Int]
torres1 n = 
    [permutacionAmatriz n p | p <- sort (permutations [1..n])]

permutacionAmatriz :: Int -> [Int] -> Matrix Int
permutacionAmatriz n p =
    matrix n n f
    where f (i,j) | (i,j) `elem` posiciones = 1
                  | otherwise               = 0
          posiciones = zip [1..n] p    

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

torres2 :: Int -> [Matrix Int]
torres2 = map fromLists . permutations . toLists . identity

-- El cálculo con la definición anterior es:
--    λ> identity 3
--    ( 1 0 0 )
--    ( 0 1 0 )
--    ( 0 0 1 )
--    
--    λ> toLists it
--    [[1,0,0],[0,1,0],[0,0,1]]
--    λ> permutations it
--    [[[1,0,0],[0,1,0],[0,0,1]],
--     [[0,1,0],[1,0,0],[0,0,1]],
--     [[0,0,1],[0,1,0],[1,0,0]],
--     [[0,1,0],[0,0,1],[1,0,0]],
--     [[0,0,1],[1,0,0],[0,1,0]],
--     [[1,0,0],[0,0,1],[0,1,0]]]
--    λ> map fromLists it
--    [( 1 0 0 )
--     ( 0 1 0 )
--     ( 0 0 1 )
--    ,( 0 1 0 )
--     ( 1 0 0 )
--     ( 0 0 1 )
--    ,( 0 0 1 )
--     ( 0 1 0 )
--     ( 1 0 0 )
--    ,( 0 1 0 )
--     ( 0 0 1 )
--     ( 1 0 0 )
--    ,( 0 0 1 )
--     ( 1 0 0 )
--     ( 0 1 0 )
--    ,( 1 0 0 )
--     ( 0 0 1 )
--     ( 0 1 0 )
--    ]

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

nTorres1 :: Int -> Integer
nTorres1 = genericLength . torres1

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

nTorres2 :: Int -> Integer
nTorres2 n = product [1..fromIntegral n]

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

--    λ> nTorres1 9
--    362880
--    (4.22 secs, 693,596,128 bytes)
--    λ> nTorres2 9
--    362880
--    (0.00 secs, 0 bytes)

import Data.List (genericLength, sort, permutations)

import Data.Matrix

-- 1ª definición de torres

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

torres1 :: Int -> [Matrix Int]

torres1 n =

[permutacionAmatriz n p | p <- sort (permutations [1..n])]

permutacionAmatriz :: Int -> [Int] -> Matrix Int

permutacionAmatriz n p =

matrix n n f

where f (i,j) | (i,j) `elem` posiciones = 1

| otherwise = 0

posiciones = zip [1..n] p

-- 2ª definición de torres

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

torres2 :: Int -> [Matrix Int]

torres2 = map fromLists . permutations . toLists . identity

-- El cálculo con la definición anterior es:

-- λ> identity 3

-- ( 1 0 0 )

-- ( 0 1 0 )

-- ( 0 0 1 )

-- λ> toLists it

-- [[1,0,0],[0,1,0],[0,0,1]]

-- λ> permutations it

-- [[[1,0,0],[0,1,0],[0,0,1]],

-- [[0,1,0],[1,0,0],[0,0,1]],

-- [[0,0,1],[0,1,0],[1,0,0]],

-- [[0,1,0],[0,0,1],[1,0,0]],

-- [[0,0,1],[1,0,0],[0,1,0]],

-- [[1,0,0],[0,0,1],[0,1,0]]]

-- λ> map fromLists it

-- [( 1 0 0 )

-- ( 0 1 0 )

-- ( 0 0 1 )

-- ,( 0 1 0 )

-- ( 1 0 0 )

-- ( 0 0 1 )

-- ,( 0 0 1 )

-- ( 0 1 0 )

-- ( 1 0 0 )

-- ,( 0 1 0 )

-- ( 0 0 1 )

-- ( 1 0 0 )

-- ,( 0 0 1 )

-- ( 1 0 0 )

-- ( 0 1 0 )

-- ,( 1 0 0 )

-- ( 0 0 1 )

-- ( 0 1 0 )

-- ]

-- 1ª definición de nTorres

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

nTorres1 :: Int -> Integer

nTorres1 = genericLength . torres1

-- 2ª definición de nTorres

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

nTorres2 :: Int -> Integer

nTorres2 n = product [1..fromIntegral n]

-- Comparación de eficiencia

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

-- λ> nTorres1 9

-- 362880

-- (4.22 secs, 693,596,128 bytes)

-- λ> nTorres2 9

-- 362880

-- (0.00 secs, 0 bytes)

[/schedule]

Reconocimiento de camino en un grafo

PorJosé A. Alonso 24-mayo-201926-marzo-2022

Dado un grafo no dirigido G, un camino en G es una secuencia de nodos [v(1),v(2),v(3),…,v(n)] tal que para todo i entre 1 y n-1, (v(i),v(i+1)) es una arista de G. Por ejemplo, dados los grafos

   g1, g2 :: Grafo Int Int
   g1 = creaGrafo ND (1,3) [(1,2,0),(1,3,0),(2,3,0)]
   g2 = creaGrafo ND (1,4) [(1,2,0),(1,3,0),(1,4,0),(2,4,0),(3,4,0)]

g1, g2 :: Grafo Int Int

g1 = creaGrafo ND (1,3) [(1,2,0),(1,3,0),(2,3,0)]

g2 = creaGrafo ND (1,4) [(1,2,0),(1,3,0),(1,4,0),(2,4,0),(3,4,0)]

la lista [1,2,3] es un camino en g1, pero no es un camino en g2 puesto que la arista (2,3) no existe en g2.

Definir la función

   camino :: Grafo Int Int -> [Int] -> Bool

1	camino :: Grafo Int Int -> [Int] -> Bool

tal que (camino g vs) se verifica si la lista de nodos vs es un camino en el grafo g. Por ejemplo,

   camino g1 [1,2,3]  ==  True
   camino g2 [1,2,3]  ==  False

1 2	camino g1 [1,2,3] == True camino g2 [1,2,3] == False

Nota: Este ejercicio debe realizarse usando únicamente las funciones de la librería de grafos (I1M.Grafo) que se describe aquí y se encuentra aquí.

Soluciones

[schedule expon=’2019-05-31′ expat=»06:00″]

Las soluciones se pueden escribir en los comentarios hasta el 31 de mayo.
El código se debe escribir entre una línea con <pre lang=»haskell»> y otra con </pre>

Pensamiento

Dijo el árbol: teme al hacha,
palo clavado en el suelo:
contigo la poda es tala.

Antonio Machado

[/schedule]

[schedule on=’2019-05-31′ at=»06:00″]

import I1M.Grafo 

g1, g2 :: Grafo Int Int
g1 = creaGrafo ND (1,3) [(1,2,0),(1,3,0),(2,3,0)]
g2 = creaGrafo ND (1,4) [(1,2,0),(1,3,0),(1,4,0),(2,4,0),(3,4,0)]

camino :: Grafo Int Int -> [Int] -> Bool
camino g vs = all (aristaEn g) (zip vs (tail vs))

import I1M.Grafo

g1, g2 :: Grafo Int Int

g1 = creaGrafo ND (1,3) [(1,2,0),(1,3,0),(2,3,0)]

g2 = creaGrafo ND (1,4) [(1,2,0),(1,3,0),(1,4,0),(2,4,0),(3,4,0)]

camino :: Grafo Int Int -> [Int] -> Bool

camino g vs = all (aristaEn g) (zip vs (tail vs))

[/schedule]

Último dígito no nulo del factorial

PorJosé A. Alonso 13-noviembre-201825-abril-2021

El factorial de 7 es

   7! = 1 * 2 * 3 * 4 * 5 * 6 * 7 = 5040

1	7! = 1 * 2 * 3 * 4 * 5 * 6 * 7 = 5040

por tanto, el último dígito no nulo del factorial de 7 es 4.

Definir la función

   ultimoNoNuloFactorial :: Integer -> Integer

1	ultimoNoNuloFactorial :: Integer -> Integer

tal que (ultimoNoNuloFactorial n) es el último dígito no nulo del factorial de n. Por ejemplo,

   ultimoNoNuloFactorial  7  == 4
   ultimoNoNuloFactorial 10  == 8
   ultimoNoNuloFactorial 12  == 6
   ultimoNoNuloFactorial 97  == 2
   ultimoNoNuloFactorial  0  == 1

ultimoNoNuloFactorial 7 == 4

ultimoNoNuloFactorial 10 == 8

ultimoNoNuloFactorial 12 == 6

ultimoNoNuloFactorial 97 == 2

ultimoNoNuloFactorial 0 == 1

Comprobar con QuickCheck que si n es mayor que 4, entonces el último dígito no nulo del factorial de n es par.

Soluciones

import Test.QuickCheck

-- 1ª definición
-- =============

ultimoNoNuloFactorial :: Integer -> Integer
ultimoNoNuloFactorial n = ultimoNoNulo (factorial n)

-- (ultimoNoNulo n) es el último dígito no nulo de n. Por ejemplo,
--    ultimoNoNulo 5040  ==  4
ultimoNoNulo :: Integer -> Integer
ultimoNoNulo n
  | m /= 0    = m
  | otherwise = ultimoNoNulo (n `div` 10)
  where m = n `rem` 10
        
-- (factorial n) es el factorial de n. Por ejemplo,
--    factorial 7  ==  5040
factorial :: Integer -> Integer
factorial n = product [1..n]

-- 2ª definición
-- =============

ultimoNoNuloFactorial2 :: Integer -> Integer
ultimoNoNuloFactorial2 n = ultimoNoNulo2 (factorial n)

-- (ultimoNoNulo2 n) es el último dígito no nulo de n. Por ejemplo,
--    ultimoNoNulo 5040  ==  4
ultimoNoNulo2 :: Integer -> Integer
ultimoNoNulo2 n = read [head (dropWhile (=='0') (reverse (show n)))]

-- Comprobación
-- ============

-- La propiedad es
prop_ultimoNoNuloFactorial :: Integer -> Property
prop_ultimoNoNuloFactorial n = 
  n > 4 ==> even (ultimoNoNuloFactorial n)
                  
-- La comprobación es
--    ghci> quickCheck prop_ultimoNoNuloFactorial
--    +++ OK, passed 100 tests.

import Test.QuickCheck

-- 1ª definición

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

ultimoNoNuloFactorial :: Integer -> Integer

ultimoNoNuloFactorial n = ultimoNoNulo (factorial n)

-- (ultimoNoNulo n) es el último dígito no nulo de n. Por ejemplo,

-- ultimoNoNulo 5040 == 4

ultimoNoNulo :: Integer -> Integer

ultimoNoNulo n

| m /= 0 = m

| otherwise = ultimoNoNulo (n `div` 10)

where m = n `rem` 10

-- (factorial n) es el factorial de n. Por ejemplo,

-- factorial 7 == 5040

factorial :: Integer -> Integer

factorial n = product [1..n]

-- 2ª definición

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

ultimoNoNuloFactorial2 :: Integer -> Integer

ultimoNoNuloFactorial2 n = ultimoNoNulo2 (factorial n)

-- (ultimoNoNulo2 n) es el último dígito no nulo de n. Por ejemplo,

-- ultimoNoNulo 5040 == 4

ultimoNoNulo2 :: Integer -> Integer

ultimoNoNulo2 n = read [head (dropWhile (=='0') (reverse (show n)))]

-- Comprobación

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

-- La propiedad es

prop_ultimoNoNuloFactorial :: Integer -> Property

prop_ultimoNoNuloFactorial n =

n > 4 ==> even (ultimoNoNuloFactorial n)

-- La comprobación es

-- ghci> quickCheck prop_ultimoNoNuloFactorial

-- +++ OK, passed 100 tests.

Pensamiento

Incierto es, lo porvenir. ¿Quién sabe lo que va a pasar? Pero incierto es también lo pretérito. ¿Quién sabe lo que ha pasado? De suerte que ni el porvenir está escrito en ninguna parte, ni el pasado tampoco.

Antonio Machado

Las sucesiones de Loomis

PorJosé A. Alonso 30-abril-201825-abril-2021

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

144

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]

Sucesión de antecesores y sucesores

PorJosé A. Alonso 2-abril-20189-abril-2018

Definir la lista

   antecesoresYsucesores :: [[Integer]]

1	antecesoresYsucesores :: [[Integer]]

cuyos elementos son

   [[1],[0,2],[-1,1,1,3],[-2,2,0,0,2,0,2,2,4],...]

1	[[1],[0,2],[-1,1,1,3],[-2,2,0,0,2,0,2,2,4],...]

donde cada una de las listas se obtiene de la anterior sustituyendo cada elemento por su antecesor y su sucesor; es decir, el 1 por el 0 y el 2, el 0 por el -1 y el 1, el 2 por el 1 y el 3, etc. Por ejemplo,

   λ> take 4 antecesoresYsucesores
   [[1],[0,2],[-1,1,1,3],[-2,0,0,2,0,2,2,4]]

1 2	λ> take 4 antecesoresYsucesores [[1],[0,2],[-1,1,1,3],[-2,0,0,2,0,2,2,4]]

Comprobar con Quickcheck que la suma de los elementos de la lista n-ésima de antecesoresYsucesores es 2^n.

Nota. Limitar la búsqueda a ejemplos pequeños usando

   quickCheckWith (stdArgs {maxSize=7}) prop_suma

1	quickCheckWith (stdArgs {maxSize=7}) prop_suma

Soluciones

import Test.QuickCheck

-- 1ª solución
antecesoresYsucesores :: [[Integer]]       
antecesoresYsucesores = 
  [1] : map (concatMap (\x -> [x-1,x+1])) antecesoresYsucesores

-- 2ª solución
antecesoresYsucesores2 :: [[Integer]]       
antecesoresYsucesores2 = 
  iterate (concatMap (\x -> [x-1,x+1])) [1]

-- La propiedad es
prop_suma :: (Positive Int) -> Bool
prop_suma (Positive n) =
  sum (antecesoresYsucesores2 !! n) == 2^n

-- La comprobación es
--    λ> quickCheckWith (stdArgs {maxSize=7}) prop_suma
--    +++ OK, passed 100 tests.

import Test.QuickCheck

-- 1ª solución

antecesoresYsucesores :: [[Integer]]

antecesoresYsucesores =

[1] : map (concatMap (\x -> [x-1,x+1])) antecesoresYsucesores

-- 2ª solución

antecesoresYsucesores2 :: [[Integer]]

antecesoresYsucesores2 =

iterate (concatMap (\x -> [x-1,x+1])) [1]

-- La propiedad es

prop_suma :: (Positive Int) -> Bool

prop_suma (Positive n) =

sum (antecesoresYsucesores2 !! n) == 2^n

-- La comprobación es

-- λ> quickCheckWith (stdArgs {maxSize=7}) prop_suma

-- +++ OK, passed 100 tests.

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas 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

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Soluciones

Entradas recientes

Buscar

Correo electrónico