Recursión – Página 2

Primos equidistantes

PorJosé A. Alonso 2-marzo-202215-abril-2022

Definir la función

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

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

tal que (primosEquidistantes k) es la lista de los pares de primos cuya diferencia es k. Por ejemplo,

   take 3 (primosEquidistantes 2)  ==  [(3,5),(5,7),(11,13)]
   take 3 (primosEquidistantes 4)  ==  [(7,11),(13,17),(19,23)]
   take 3 (primosEquidistantes 6)  ==  [(23,29),(31,37),(47,53)]
   take 3 (primosEquidistantes 8)  ==  [(89,97),(359,367),(389,397)]
   primosEquidistantes 4 !! (10^5) ==  (18467047,18467051)

take 3 (primosEquidistantes 2) == [(3,5),(5,7),(11,13)]

take 3 (primosEquidistantes 4) == [(7,11),(13,17),(19,23)]

take 3 (primosEquidistantes 6) == [(23,29),(31,37),(47,53)]

take 3 (primosEquidistantes 8) == [(89,97),(359,367),(389,397)]

primosEquidistantes 4 !! (10^5) == (18467047,18467051)

Soluciones

import Data.Numbers.Primes (primes)

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

primosEquidistantes1 :: Integer -> [(Integer,Integer)]
primosEquidistantes1 k = aux primos
  where aux (x:y:ps) | y - x == k = (x,y) : aux (y:ps)
                     | otherwise  = aux (y:ps)

-- (primo x) se verifica si x es primo. Por ejemplo,
--    primo 7  ==  True
--    primo 8  ==  False
primo :: Integer -> Bool
primo x = [y | y <- [1..x], x `rem` y == 0] == [1,x]

-- primos es la lista de los números primos. Por ejemplo,
--    take 10 primos  ==  [2,3,5,7,11,13,17,19,23,29]
primos :: [Integer]
primos = 2 : [x | x <- [3,5..], primo x]

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

primosEquidistantes2 :: Integer -> [(Integer,Integer)]
primosEquidistantes2 k = aux primos2
  where aux (x:y:ps) | y - x == k = (x,y) : aux (y:ps)
                     | otherwise  = aux (y:ps)

primos2 :: [Integer]
primos2 = criba [2..]
  where criba (p:ps) = p : criba [n | n <- ps, mod n p /= 0]

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

primosEquidistantes3 :: Integer -> [(Integer,Integer)]
primosEquidistantes3 k =
  [(x,y) | (x,y) <- zip primos2 (tail primos2)
         , y - x == k]

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

primosEquidistantes4 :: Integer -> [(Integer,Integer)]
primosEquidistantes4 k = aux primes
  where aux (x:y:ps) | y - x == k = (x,y) : aux (y:ps)
                     | otherwise  = aux (y:ps)

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

primosEquidistantes5 :: Integer -> [(Integer,Integer)]
primosEquidistantes5 k =
  [(x,y) | (x,y) <- zip primes (tail primes)
         , y - x == k]

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

-- La propiedad es
prop_primosEquidistantes :: Int -> Integer -> Bool
prop_primosEquidistantes n k =
  all (== take n (primosEquidistantes1 k))
      [take n (f k) | f <- [primosEquidistantes2,
                            primosEquidistantes3,
                            primosEquidistantes4,
                            primosEquidistantes5]]

-- La comprobación es
--    λ> prop_primosEquidistantes 100 4
--    True

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

-- La comparación es
--    λ> primosEquidistantes1 4 !! 200
--    (9829,9833)
--    (2.60 secs, 1,126,458,272 bytes)
--    λ> primosEquidistantes2 4 !! 200
--    (9829,9833)
--    (0.44 secs, 249,622,048 bytes)
--    λ> primosEquidistantes3 4 !! 200
--    (9829,9833)
--    (0.36 secs, 207,549,592 bytes)
--    λ> primosEquidistantes4 4 !! 200
--    (9829,9833)
--    (0.02 secs, 4,012,848 bytes)
--    λ> primosEquidistantes5 4 !! 200
--    (9829,9833)
--    (0.01 secs, 7,085,072 bytes)
--
--    λ> primosEquidistantes2 4 !! 600
--    (41617,41621)
--    (5.67 secs, 3,340,313,480 bytes)
--    λ> primosEquidistantes3 4 !! 600
--    (41617,41621)
--    (5.43 secs, 3,090,994,096 bytes)
--    λ> primosEquidistantes4 4 !! 600
--    (41617,41621)
--    (0.03 secs, 15,465,824 bytes)
--    λ> primosEquidistantes5 4 !! 600
--    (41617,41621)
--    (0.04 secs, 28,858,232 bytes)
--
--    λ> primosEquidistantes4 4 !! (10^5)
--    (18467047,18467051)
--    (3.99 secs, 9,565,715,488 bytes)
--    λ> primosEquidistantes5 4 !! (10^5)
--    (18467047,18467051)
--    (7.95 secs, 18,712,469,144 bytes)

100

101

102

103

104

105

106

107

108

109

110

111

112

import Data.Numbers.Primes (primes)

-- 1ª solución

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

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

primosEquidistantes1 k = aux primos

where aux (x:y:ps) | y - x == k = (x,y) : aux (y:ps)

| otherwise = aux (y:ps)

-- (primo x) se verifica si x es primo. Por ejemplo,

-- primo 7 == True

-- primo 8 == False

primo :: Integer -> Bool

primo x = [y | y <- [1..x], x `rem` y == 0] == [1,x]

-- primos es la lista de los números primos. Por ejemplo,

-- take 10 primos == [2,3,5,7,11,13,17,19,23,29]

primos :: [Integer]

primos = 2 : [x | x <- [3,5..], primo x]

-- 2ª solución

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

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

primosEquidistantes2 k = aux primos2

where aux (x:y:ps) | y - x == k = (x,y) : aux (y:ps)

| otherwise = aux (y:ps)

primos2 :: [Integer]

primos2 = criba [2..]

where criba (p:ps) = p : criba [n | n <- ps, mod n p /= 0]

-- 3ª solución

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

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

primosEquidistantes3 k =

[(x,y) | (x,y) <- zip primos2 (tail primos2)

, y - x == k]

-- 4ª solución

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

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

primosEquidistantes4 k = aux primes

where aux (x:y:ps) | y - x == k = (x,y) : aux (y:ps)

| otherwise = aux (y:ps)

-- 5ª solución

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

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

primosEquidistantes5 k =

[(x,y) | (x,y) <- zip primes (tail primes)

, y - x == k]

-- Comprobación de equivalencia

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

-- La propiedad es

prop_primosEquidistantes :: Int -> Integer -> Bool

prop_primosEquidistantes n k =

all (== take n (primosEquidistantes1 k))

[take n (f k) | f <- [primosEquidistantes2,

primosEquidistantes3,

primosEquidistantes4,

primosEquidistantes5]]

-- La comprobación es

-- λ> prop_primosEquidistantes 100 4

-- True

-- Comparación de eficiencia

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

-- La comparación es

-- λ> primosEquidistantes1 4 !! 200

-- (9829,9833)

-- (2.60 secs, 1,126,458,272 bytes)

-- λ> primosEquidistantes2 4 !! 200

-- (9829,9833)

-- (0.44 secs, 249,622,048 bytes)

-- λ> primosEquidistantes3 4 !! 200

-- (9829,9833)

-- (0.36 secs, 207,549,592 bytes)

-- λ> primosEquidistantes4 4 !! 200

-- (9829,9833)

-- (0.02 secs, 4,012,848 bytes)

-- λ> primosEquidistantes5 4 !! 200

-- (9829,9833)

-- (0.01 secs, 7,085,072 bytes)

-- λ> primosEquidistantes2 4 !! 600

-- (41617,41621)

-- (5.67 secs, 3,340,313,480 bytes)

-- λ> primosEquidistantes3 4 !! 600

-- (41617,41621)

-- (5.43 secs, 3,090,994,096 bytes)

-- λ> primosEquidistantes4 4 !! 600

-- (41617,41621)

-- (0.03 secs, 15,465,824 bytes)

-- λ> primosEquidistantes5 4 !! 600

-- (41617,41621)

-- (0.04 secs, 28,858,232 bytes)

-- λ> primosEquidistantes4 4 !! (10^5)

-- (18467047,18467051)

-- (3.99 secs, 9,565,715,488 bytes)

-- λ> primosEquidistantes5 4 !! (10^5)

-- (18467047,18467051)

-- (7.95 secs, 18,712,469,144 bytes)

El código se encuentra en GitHub.

Anagramas

PorJosé A. Alonso 1-marzo-20228-marzo-2022

Una palabra es una anagrama de otra si se puede obtener permutando sus letras. Por ejemplo, «mora» y «roma» son anagramas de «amor».

Definir la función

   anagramas :: String -> [String] -> [String]

1	anagramas :: String -> [String] -> [String]

tal que (anagramas x ys) es la lista de los elementos de ys que son anagramas de x. Por ejemplo,

   λ> anagramas "amor" ["Roma","mola","loma","moRa", "rama"]
   ["Roma","moRa"]
   λ> anagramas "rama" ["aMar","amaRa","roMa","marr","aRma"]
   ["aMar","aRma"]

λ> anagramas "amor" ["Roma","mola","loma","moRa", "rama"]

["Roma","moRa"]

λ> anagramas "rama" ["aMar","amaRa","roMa","marr","aRma"]

["aMar","aRma"]

Soluciones

import Data.List (delete, permutations, sort)
import Data.Char (toLower)
import Data.Function (on)

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

anagramas :: String -> [String] -> [String]
anagramas _ [] = []
anagramas x (y:ys)
  | sonAnagramas x y = y : anagramas x ys
  | otherwise        = anagramas x ys

-- (sonAnagramas xs ys) se verifica si xs e ys son anagramas. Por
-- ejemplo,
--    sonAnagramas "amor" "Roma"  ==  True
--    sonAnagramas "amor" "mola"  ==  False
sonAnagramas :: String -> String -> Bool
sonAnagramas xs ys =
  sort (map toLower xs) == sort (map toLower ys)

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

anagramas2 :: String -> [String] -> [String]
anagramas2 _ [] = []
anagramas2 x (y:ys)
  | sonAnagramas2 x y = y : anagramas2 x ys
  | otherwise         = anagramas2 x ys

sonAnagramas2 :: String -> String -> Bool
sonAnagramas2 xs ys =
  (sort . map toLower) xs == (sort . map toLower) ys

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

anagramas3 :: String -> [String] -> [String]
anagramas3 _ [] = []
anagramas3 x (y:ys)
  | sonAnagramas3 x y = y : anagramas3 x ys
  | otherwise         = anagramas3 x ys

sonAnagramas3 :: String -> String -> Bool
sonAnagramas3 = (==) `on` (sort . map toLower)

-- Nota. En la solución anterior se usa la función on ya que
--    (f `on` g) x y
-- es equivalente a
--    f (g x) (g y)
-- Por ejemplo,
--    λ> ((*) `on` (+2)) 3 4
--    30

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

anagramas4 :: String -> [String] -> [String]
anagramas4 x ys = [y | y <- ys, sonAnagramas x y]

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

anagramas5 :: String -> [String] -> [String]
anagramas5 x = filter (`sonAnagramas` x)

-- 6ª solución
-- ===========

anagramas6 :: String -> [String] -> [String]
anagramas6 x = filter (((==) `on` (sort . map toLower)) x)

-- 7ª solución
-- ===========

anagramas7 :: String -> [String] -> [String]
anagramas7 _ [] = []
anagramas7 x (y:ys)
  | sonAnagramas7 x y = y : anagramas7 x ys
  | otherwise         = anagramas7 x ys

sonAnagramas7 :: String -> String -> Bool
sonAnagramas7 xs ys = aux (map toLower xs) (map toLower ys)
  where
    aux [] [] = True
    aux [] _  = False
    aux (u:us) vs | u `notElem` vs = False
                  | otherwise      = aux us (delete u vs)

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

-- La comparación es
--    λ> ej = take (10^6) (permutations "1234567890")
--    λ> length (anagramas "1234567890" ej)
--    1000000
--    (2.27 secs, 5,627,236,104 bytes)
--    λ> length (anagramas2 "1234567890" ej)
--    1000000
--    (2.80 secs, 5,513,260,584 bytes)
--    λ> length (anagramas3 "1234567890" ej)
--    1000000
--    (1.86 secs, 5,097,260,856 bytes)
--    λ> length (anagramas4 "1234567890" ej)
--    1000000
--    (2.25 secs, 5,073,260,632 bytes)
--    λ> length (anagramas5 "1234567890" ej)
--    1000000
--    (2.14 secs, 5,009,260,616 bytes)
--    λ> length (anagramas6 "1234567890" ej)
--    1000000
--    (1.58 secs, 4,977,260,976 bytes)
--    λ> length (anagramas7 "1234567890" ej)
--    1000000
--    (6.63 secs, 6,904,821,648 bytes)

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

import Data.List (delete, permutations, sort)

import Data.Char (toLower)

import Data.Function (on)

-- 1ª solución

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

anagramas :: String -> [String] -> [String]

anagramas _ [] = []

anagramas x (y:ys)

| sonAnagramas x y = y : anagramas x ys

| otherwise = anagramas x ys

-- (sonAnagramas xs ys) se verifica si xs e ys son anagramas. Por

-- ejemplo,

-- sonAnagramas "amor" "Roma" == True

-- sonAnagramas "amor" "mola" == False

sonAnagramas :: String -> String -> Bool

sonAnagramas xs ys =

sort (map toLower xs) == sort (map toLower ys)

-- 2ª solución

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

anagramas2 :: String -> [String] -> [String]

anagramas2 _ [] = []

anagramas2 x (y:ys)

| sonAnagramas2 x y = y : anagramas2 x ys

| otherwise = anagramas2 x ys

sonAnagramas2 :: String -> String -> Bool

sonAnagramas2 xs ys =

(sort . map toLower) xs == (sort . map toLower) ys

-- 3ª solución

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

anagramas3 :: String -> [String] -> [String]

anagramas3 _ [] = []

anagramas3 x (y:ys)

| sonAnagramas3 x y = y : anagramas3 x ys

| otherwise = anagramas3 x ys

sonAnagramas3 :: String -> String -> Bool

sonAnagramas3 = (==) `on` (sort . map toLower)

-- Nota. En la solución anterior se usa la función on ya que

-- (f `on` g) x y

-- es equivalente a

-- f (g x) (g y)

-- Por ejemplo,

-- λ> ((*) `on` (+2)) 3 4

-- 30

-- 4ª solución

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

anagramas4 :: String -> [String] -> [String]

anagramas4 x ys = [y | y <- ys, sonAnagramas x y]

-- 5ª solución

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

anagramas5 :: String -> [String] -> [String]

anagramas5 x = filter (`sonAnagramas` x)

-- 6ª solución

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

anagramas6 :: String -> [String] -> [String]

anagramas6 x = filter (((==) `on` (sort . map toLower)) x)

-- 7ª solución

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

anagramas7 :: String -> [String] -> [String]

anagramas7 _ [] = []

anagramas7 x (y:ys)

| sonAnagramas7 x y = y : anagramas7 x ys

| otherwise = anagramas7 x ys

sonAnagramas7 :: String -> String -> Bool

sonAnagramas7 xs ys = aux (map toLower xs) (map toLower ys)

where

aux [] [] = True

aux [] _ = False

aux (u:us) vs | u `notElem` vs = False

| otherwise = aux us (delete u vs)

-- Comparación de eficiencia

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

-- La comparación es

-- λ> ej = take (10^6) (permutations "1234567890")

-- λ> length (anagramas "1234567890" ej)

-- 1000000

-- (2.27 secs, 5,627,236,104 bytes)

-- λ> length (anagramas2 "1234567890" ej)

-- 1000000

-- (2.80 secs, 5,513,260,584 bytes)

-- λ> length (anagramas3 "1234567890" ej)

-- 1000000

-- (1.86 secs, 5,097,260,856 bytes)

-- λ> length (anagramas4 "1234567890" ej)

-- 1000000

-- (2.25 secs, 5,073,260,632 bytes)

-- λ> length (anagramas5 "1234567890" ej)

-- 1000000

-- (2.14 secs, 5,009,260,616 bytes)

-- λ> length (anagramas6 "1234567890" ej)

-- 1000000

-- (1.58 secs, 4,977,260,976 bytes)

-- λ> length (anagramas7 "1234567890" ej)

-- 1000000

-- (6.63 secs, 6,904,821,648 bytes)

El código se encuentra en GitHub.

La bandera tricolor

PorJosé A. Alonso 28-febrero-20227-marzo-2022

El problema de la bandera tricolor consiste en lo siguiente: Dada un lista de objetos xs que pueden ser rojos, amarillos o morados, se pide devolver una lista ys que contiene los elementos de xs, primero los rojos, luego los amarillos y por último los morados.

Definir el tipo de dato Color para representar los colores con los constructores R, A y M correspondientes al rojo, azul y morado y la función

   banderaTricolor :: [Color] -> [Color]

1	banderaTricolor :: [Color] -> [Color]

tal que (banderaTricolor xs) es la bandera tricolor formada con los elementos de xs. Por ejemplo,

   bandera [M,R,A,A,R,R,A,M,M]  ==  [R,R,R,A,A,A,M,M,M]
   bandera [M,R,A,R,R,A]        ==  [R,R,R,A,A,M]

1 2	bandera [M,R,A,A,R,R,A,M,M] == [R,R,R,A,A,A,M,M,M] bandera [M,R,A,R,R,A] == [R,R,R,A,A,M]

Soluciones

import Data.List (sort)
import Test.QuickCheck (Arbitrary(arbitrary), elements, quickCheck)

data Color = R | A | M
  deriving (Show, Eq, Ord, Enum)

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

banderaTricolor1 :: [Color] -> [Color]
banderaTricolor1 xs =
  [x | x <- xs, x == R] ++
  [x | x <- xs, x == A] ++
  [x | x <- xs, x == M]

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

banderaTricolor2 :: [Color] -> [Color]
banderaTricolor2 xs =
  colores R ++ colores A ++ colores M
  where colores c = filter (== c) xs

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

banderaTricolor3 :: [Color] -> [Color]
banderaTricolor3 xs =
  concat [[x | x <- xs, x == c] | c <- [R,A,M]]

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

banderaTricolor4 :: [Color] -> [Color]
banderaTricolor4 xs = aux xs ([],[],[])
  where aux []     (rs,as,ms) = rs ++ as ++ ms
        aux (R:ys) (rs,as,ms) = aux ys (R:rs,   as,   ms)
        aux (A:ys) (rs,as,ms) = aux ys (  rs, A:as,   ms)
        aux (M:ys) (rs,as,ms) = aux ys (  rs,   as, M:ms)

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

banderaTricolor5 :: [Color] -> [Color]
banderaTricolor5 = sort

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

instance Arbitrary Color where
  arbitrary = elements [A,R,M]

-- La propiedad es
prop_banderaTricolor :: [Color] -> Bool
prop_banderaTricolor xs =
  all (== banderaTricolor1 xs)
      [banderaTricolor2 xs,
       banderaTricolor3 xs,
       banderaTricolor4 xs,
       banderaTricolor5 xs]

verifica_banderaTricolor :: IO ()
verifica_banderaTricolor =
  quickCheck prop_banderaTricolor

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

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

-- La comparación es
--    λ> bandera n = concat [replicate n c | c <- [M,R,A]]
--    λ> length (banderaTricolor1 (bandera (10^6)))
--    3000000
--    (1.51 secs, 1,024,454,768 bytes)
--    λ> length (banderaTricolor1 (bandera (2*10^6)))
--    6000000
--    (2.94 secs, 2,048,454,832 bytes)
--    λ> length (banderaTricolor2 (bandera (2*10^6)))
--    6000000
--    (2.35 secs, 1,232,454,920 bytes)
--    λ> length (banderaTricolor3 (bandera (2*10^6)))
--    6000000
--    (4.28 secs, 2,304,455,360 bytes)
--    λ> length (banderaTricolor4 (bandera (2*10^6)))
--    6000000
--    (3.01 secs, 1,904,454,672 bytes)
--    λ> length (banderaTricolor5 (bandera (2*10^6)))
--    6000000
--    (2.47 secs, 1,248,454,744 bytes)

import Data.List (sort)

import Test.QuickCheck (Arbitrary(arbitrary), elements, quickCheck)

data Color = R | A | M

deriving (Show, Eq, Ord, Enum)

-- 1ª solución

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

banderaTricolor1 :: [Color] -> [Color]

banderaTricolor1 xs =

[x | x <- xs, x == R] ++

[x | x <- xs, x == A] ++

[x | x <- xs, x == M]

-- 2ª solución

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

banderaTricolor2 :: [Color] -> [Color]

banderaTricolor2 xs =

colores R ++ colores A ++ colores M

where colores c = filter (== c) xs

-- 3ª solución

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

banderaTricolor3 :: [Color] -> [Color]

banderaTricolor3 xs =

concat [[x | x <- xs, x == c] | c <- [R,A,M]]

-- 4ª solución

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

banderaTricolor4 :: [Color] -> [Color]

banderaTricolor4 xs = aux xs ([],[],[])

where aux [] (rs,as,ms) = rs ++ as ++ ms

aux (R:ys) (rs,as,ms) = aux ys (R:rs, as, ms)

aux (A:ys) (rs,as,ms) = aux ys ( rs, A:as, ms)

aux (M:ys) (rs,as,ms) = aux ys ( rs, as, M:ms)

-- 5ª solución

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

banderaTricolor5 :: [Color] -> [Color]

banderaTricolor5 = sort

-- Comprobación de equivalencia

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

instance Arbitrary Color where

arbitrary = elements [A,R,M]

-- La propiedad es

prop_banderaTricolor :: [Color] -> Bool

prop_banderaTricolor xs =

all (== banderaTricolor1 xs)

[banderaTricolor2 xs,

banderaTricolor3 xs,

banderaTricolor4 xs,

banderaTricolor5 xs]

verifica_banderaTricolor :: IO ()

verifica_banderaTricolor =

quickCheck prop_banderaTricolor

-- La comprobación es

-- λ> verifica_banderaTricolor

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> bandera n = concat [replicate n c | c <- [M,R,A]]

-- λ> length (banderaTricolor1 (bandera (10^6)))

-- 3000000

-- (1.51 secs, 1,024,454,768 bytes)

-- λ> length (banderaTricolor1 (bandera (2*10^6)))

-- 6000000

-- (2.94 secs, 2,048,454,832 bytes)

-- λ> length (banderaTricolor2 (bandera (2*10^6)))

-- 6000000

-- (2.35 secs, 1,232,454,920 bytes)

-- λ> length (banderaTricolor3 (bandera (2*10^6)))

-- 6000000

-- (4.28 secs, 2,304,455,360 bytes)

-- λ> length (banderaTricolor4 (bandera (2*10^6)))

-- 6000000

-- (3.01 secs, 1,904,454,672 bytes)

-- λ> length (banderaTricolor5 (bandera (2*10^6)))

-- 6000000

-- (2.47 secs, 1,248,454,744 bytes)

El código se encuentra en GitHub.

Iguales al siguiente

PorJosé A. Alonso 24-febrero-20223-marzo-2022

Definir la función

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

1	igualesAlSiguiente :: Eq a => [a] -> [a]

tal que (igualesAlSiguiente xs) es la lista de los elementos de xs que son iguales a su siguiente. Por ejemplo,

   igualesAlSiguiente [1,2,2,2,3,3,4]  ==  [2,2,3]
   igualesAlSiguiente [1..10]          ==  []

1 2	igualesAlSiguiente [1,2,2,2,3,3,4] == [2,2,3] igualesAlSiguiente [1..10] == []

Soluciones

import Data.List (group)
import Test.QuickCheck (quickCheck)

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

igualesAlSiguiente1 :: Eq a => [a] -> [a]
igualesAlSiguiente1 xs =
  [x | (x, y) <- consecutivos1 xs, x == y]

-- (consecutivos1 xs) es la lista de pares de elementos consecutivos en
-- xs. Por ejemplo,
--    consecutivos1 [3,5,2,7]  ==  [(3,5),(5,2),(2,7)]
consecutivos1 :: [a] -> [(a, a)]
consecutivos1 xs = zip xs (tail xs)

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

igualesAlSiguiente2 :: Eq a => [a] -> [a]
igualesAlSiguiente2 xs =
  [x | (x,y) <- consecutivos2 xs, x == y]

-- (consecutivos2 xs) es la lista de pares de elementos consecutivos en
-- xs. Por ejemplo,
--    consecutivos2 [3,5,2,7]  ==  [(3,5),(5,2),(2,7)]
consecutivos2 :: [a] -> [(a, a)]
consecutivos2 (x:y:zs) = (x,y) : consecutivos2 (y:zs)
consecutivos2 _        = []

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

igualesAlSiguiente3 :: Eq a => [a] -> [a]
igualesAlSiguiente3 (x:y:zs) | x == y    = x : igualesAlSiguiente3 (y:zs)
                             | otherwise = igualesAlSiguiente3 (y:zs)
igualesAlSiguiente3 _                    = []

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

igualesAlSiguiente4 :: Eq a => [a] -> [a]
igualesAlSiguiente4 xs = concat [ys | (_:ys) <- group xs]

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

igualesAlSiguiente5 :: Eq a => [a] -> [a]
igualesAlSiguiente5 xs = concat (map tail (group xs))

-- 6ª solución
-- ===========

igualesAlSiguiente6 :: Eq a => [a] -> [a]
igualesAlSiguiente6 xs = tail =<< group xs

-- 7ª solución
-- ===========

igualesAlSiguiente7 :: Eq a => [a] -> [a]
igualesAlSiguiente7 = (tail =<<) . group

-- 8ª solución
-- ===========

igualesAlSiguiente8 :: Eq a => [a] -> [a]
igualesAlSiguiente8 xs = concatMap tail (group xs)

-- 9ª solución
-- ===========

igualesAlSiguiente9 :: Eq a => [a] -> [a]
igualesAlSiguiente9 = concatMap tail . group

-- 10ª solución
-- ===========

igualesAlSiguiente10 :: Eq a => [a] -> [a]
igualesAlSiguiente10 xs = aux xs (tail xs)
  where aux (u:us) (v:vs) | u == v    = u : aux us vs
                          | otherwise = aux us vs
        aux _ _ = []

-- Equivalencia de las definiciones
-- ================================

-- La propiedad es
prop_igualesAlSiguiente :: [Int] -> Bool
prop_igualesAlSiguiente xs =
  all (== igualesAlSiguiente1 xs)
      [igualesAlSiguiente2 xs,
       igualesAlSiguiente3 xs,
       igualesAlSiguiente4 xs,
       igualesAlSiguiente5 xs,
       igualesAlSiguiente6 xs,
       igualesAlSiguiente7 xs,
       igualesAlSiguiente8 xs,
       igualesAlSiguiente9 xs,
       igualesAlSiguiente10 xs]

verificacion :: IO ()
verificacion = quickCheck prop_igualesAlSiguiente

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

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

-- La comparación es
--    > ej = concatMap show [1..10^6]
--    (0.01 secs, 446,752 bytes)
--    λ> length ej
--    5888896
--    (0.16 secs, 669,787,856 bytes)
--    λ> length (show (igualesAlSiguiente1 ej))
--    588895
--    (1.60 secs, 886,142,944 bytes)
--    λ> length (show (igualesAlSiguiente2 ej))
--    588895
--    (1.95 secs, 1,734,143,816 bytes)
--    λ> length (show (igualesAlSiguiente3 ej))
--    588895
--    (1.81 secs, 1,178,232,104 bytes)
--    λ> length (show (igualesAlSiguiente4 ej))
--    588895
--    (1.43 secs, 1,932,010,304 bytes)
--    λ> length (show (igualesAlSiguiente5 ej))
--    588895
--    (0.40 secs, 2,016,810,320 bytes)
--    λ> length (show (igualesAlSiguiente6 ej))
--    588895
--    (0.32 secs, 1,550,409,984 bytes)
--    λ> length (show (igualesAlSiguiente7 ej))
--    588895
--    (0.34 secs, 1,550,410,104 bytes)
--    λ> length (show (igualesAlSiguiente8 ej))
--    588895
--    (0.33 secs, 1,550,410,024 bytes)
--    λ> length (show (igualesAlSiguiente9 ej))
--    588895
--    (0.33 secs, 1,550,450,968 bytes)
--    λ> length (show (igualesAlSiguiente10 ej))
--    588895
--    (1.54 secs, 754,272,600 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

import Data.List (group)

import Test.QuickCheck (quickCheck)

-- 1ª solución

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

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

igualesAlSiguiente1 xs =

[x | (x, y) <- consecutivos1 xs, x == y]

-- (consecutivos1 xs) es la lista de pares de elementos consecutivos en

-- xs. Por ejemplo,

-- consecutivos1 [3,5,2,7] == [(3,5),(5,2),(2,7)]

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

consecutivos1 xs = zip xs (tail xs)

-- 2ª solución

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

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

igualesAlSiguiente2 xs =

[x | (x,y) <- consecutivos2 xs, x == y]

-- (consecutivos2 xs) es la lista de pares de elementos consecutivos en

-- xs. Por ejemplo,

-- consecutivos2 [3,5,2,7] == [(3,5),(5,2),(2,7)]

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

consecutivos2 (x:y:zs) = (x,y) : consecutivos2 (y:zs)

consecutivos2 _ = []

-- 3ª solución

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

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

igualesAlSiguiente3 (x:y:zs) | x == y = x : igualesAlSiguiente3 (y:zs)

| otherwise = igualesAlSiguiente3 (y:zs)

igualesAlSiguiente3 _ = []

-- 4ª solución

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

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

igualesAlSiguiente4 xs = concat [ys | (_:ys) <- group xs]

-- 5ª solución

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

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

igualesAlSiguiente5 xs = concat (map tail (group xs))

-- 6ª solución

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

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

igualesAlSiguiente6 xs = tail =<< group xs

-- 7ª solución

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

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

igualesAlSiguiente7 = (tail =<<) . group

-- 8ª solución

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

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

igualesAlSiguiente8 xs = concatMap tail (group xs)

-- 9ª solución

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

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

igualesAlSiguiente9 = concatMap tail . group

-- 10ª solución

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

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

igualesAlSiguiente10 xs = aux xs (tail xs)

where aux (u:us) (v:vs) | u == v = u : aux us vs

| otherwise = aux us vs

aux _ _ = []

-- Equivalencia de las definiciones

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

-- La propiedad es

prop_igualesAlSiguiente :: [Int] -> Bool

prop_igualesAlSiguiente xs =

all (== igualesAlSiguiente1 xs)

[igualesAlSiguiente2 xs,

igualesAlSiguiente3 xs,

igualesAlSiguiente4 xs,

igualesAlSiguiente5 xs,

igualesAlSiguiente6 xs,

igualesAlSiguiente7 xs,

igualesAlSiguiente8 xs,

igualesAlSiguiente9 xs,

igualesAlSiguiente10 xs]

verificacion :: IO ()

verificacion = quickCheck prop_igualesAlSiguiente

-- La comprobación es

-- λ> verificacion

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- > ej = concatMap show [1..10^6]

-- (0.01 secs, 446,752 bytes)

-- λ> length ej

-- 5888896

-- (0.16 secs, 669,787,856 bytes)

-- λ> length (show (igualesAlSiguiente1 ej))

-- 588895

-- (1.60 secs, 886,142,944 bytes)

-- λ> length (show (igualesAlSiguiente2 ej))

-- 588895

-- (1.95 secs, 1,734,143,816 bytes)

-- λ> length (show (igualesAlSiguiente3 ej))

-- 588895

-- (1.81 secs, 1,178,232,104 bytes)

-- λ> length (show (igualesAlSiguiente4 ej))

-- 588895

-- (1.43 secs, 1,932,010,304 bytes)

-- λ> length (show (igualesAlSiguiente5 ej))

-- 588895

-- (0.40 secs, 2,016,810,320 bytes)

-- λ> length (show (igualesAlSiguiente6 ej))

-- 588895

-- (0.32 secs, 1,550,409,984 bytes)

-- λ> length (show (igualesAlSiguiente7 ej))

-- 588895

-- (0.34 secs, 1,550,410,104 bytes)

-- λ> length (show (igualesAlSiguiente8 ej))

-- 588895

-- (0.33 secs, 1,550,410,024 bytes)

-- λ> length (show (igualesAlSiguiente9 ej))

-- 588895

-- (0.33 secs, 1,550,450,968 bytes)

-- λ> length (show (igualesAlSiguiente10 ej))

-- 588895

-- (1.54 secs, 754,272,600 bytes)

El código se encuentra en GitHub.

Primos consecutivos con media capicúa

PorJosé A. Alonso 23-febrero-202215-abril-2022

Definir la lista

   primosConsecutivosConMediaCapicua :: [(Int,Int,Int)]

1	primosConsecutivosConMediaCapicua :: [(Int,Int,Int)]

formada por las ternas (x,y,z) tales que x e y son primos consecutivos cuya media, z, es capicúa. Por ejemplo,

   λ> take 5 primosConsecutivosConMediaCapicua
   [(3,5,4),(5,7,6),(7,11,9),(97,101,99),(109,113,111)]
   λ> primosConsecutivosConMediaCapicua !! 500
   (5687863,5687867,5687865)

λ> take 5 primosConsecutivosConMediaCapicua

[(3,5,4),(5,7,6),(7,11,9),(97,101,99),(109,113,111)]

λ> primosConsecutivosConMediaCapicua !! 500

(5687863,5687867,5687865)

Soluciones

import Data.List (genericTake)
import Data.Numbers.Primes (primes)

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

primosConsecutivosConMediaCapicua :: [(Integer,Integer,Integer)]
primosConsecutivosConMediaCapicua =
  [(x,y,z) | (x,y) <- zip primosImpares (tail primosImpares),
             let z = (x + y) `div` 2,
             capicua z]

-- (primo x) se verifica si x es primo. Por ejemplo,
--    primo 7  ==  True
--    primo 8  ==  False
primo :: Integer -> Bool
primo x = [y | y <- [1..x], x `rem` y == 0] == [1,x]

-- primosImpares es la lista de los números primos impares. Por ejemplo,
--    take 10 primosImpares  ==  [3,5,7,11,13,17,19,23,29]
primosImpares :: [Integer]
primosImpares = [x | x <- [3,5..], primo x]

-- (capicua x) se verifica si x es capicúa. Por ejemplo,
capicua :: Integer -> Bool
capicua x = ys == reverse ys
  where ys = show x

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

primosConsecutivosConMediaCapicua2 :: [(Integer,Integer,Integer)]
primosConsecutivosConMediaCapicua2 =
  [(x,y,z) | (x,y) <- zip primosImpares2 (tail primosImpares2),
             let z = (x + y) `div` 2,
             capicua z]

primosImpares2 :: [Integer]
primosImpares2 = tail (criba [2..])
  where criba (p:ps) = p : criba [n | n <- ps, mod n p /= 0]
        criba []     = error "Imposible"

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

primosConsecutivosConMediaCapicua3 :: [(Integer,Integer,Integer)]
primosConsecutivosConMediaCapicua3 =
  [(x,y,z) | (x,y) <- zip (tail primos3) (drop 2 primos3),
             let z = (x + y) `div` 2,
             capicua z]

primos3 :: [Integer]
primos3 = 2 : 3 : criba3 0 (tail primos3) 3
  where criba3 k (p:ps) x = [n | n <- [x+2,x+4..p*p-2],
                                 and [n `rem` q /= 0 | q <- take k (tail primos3)]]
                            ++ criba3 (k+1) ps (p*p)
        criba3 _ [] _     = error "Imposible"

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

primosConsecutivosConMediaCapicua4 :: [(Integer,Integer,Integer)]
primosConsecutivosConMediaCapicua4 =
  [(x,y,z) | (x,y) <- zip (tail primes) (drop 2 primes),
             let z = (x + y) `div` 2,
             capicua z]

-- Equivalencia de definiciones
-- ============================

-- La propiedad es
prop_primosConsecutivosConMediaCapicua :: Integer -> Bool
prop_primosConsecutivosConMediaCapicua n =
  all (== genericTake n primosConsecutivosConMediaCapicua)
      [genericTake n primosConsecutivosConMediaCapicua2,
       genericTake n primosConsecutivosConMediaCapicua3,
       genericTake n primosConsecutivosConMediaCapicua4]

-- La comprobación es
--    λ> prop_primosConsecutivosConMediaCapicua 25 {-# SCC "" #-}
--    True

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

-- La comparación es
--    λ> primosConsecutivosConMediaCapicua !! 30
--    (12919,12923,12921)
--    (4.60 secs, 1,877,064,288 bytes)
--    λ> primosConsecutivosConMediaCapicua2 !! 30
--    (12919,12923,12921)
--    (0.69 secs, 407,055,848 bytes)
--    λ> primosConsecutivosConMediaCapicua3 !! 30
--    (12919,12923,12921)
--    (0.07 secs, 18,597,104 bytes)
--    λ> primosConsecutivosConMediaCapicua4 !! 30
--    (12919,12923,12921)
--    (0.01 secs, 10,065,784 bytes)
--
--    λ> primosConsecutivosConMediaCapicua2 !! 40
--    (29287,29297,29292)
--    (2.67 secs, 1,775,554,576 bytes)
--    λ> primosConsecutivosConMediaCapicua3 !! 40
--    (29287,29297,29292)
--    (0.09 secs, 32,325,808 bytes)
--    λ> primosConsecutivosConMediaCapicua4 !! 40
--    (29287,29297,29292)
--    (0.01 secs, 22,160,072 bytes)
--
--    λ> primosConsecutivosConMediaCapicua3 !! 150
--    (605503,605509,605506)
--    (3.68 secs, 2,298,403,864 bytes)
--    λ> primosConsecutivosConMediaCapicua4 !! 150
--    (605503,605509,605506)
--    (0.24 secs, 491,917,240 bytes)

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

import Data.List (genericTake)

import Data.Numbers.Primes (primes)

-- 1ª solución

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

primosConsecutivosConMediaCapicua :: [(Integer,Integer,Integer)]

primosConsecutivosConMediaCapicua =

[(x,y,z) | (x,y) <- zip primosImpares (tail primosImpares),

let z = (x + y) `div` 2,

capicua z]

-- (primo x) se verifica si x es primo. Por ejemplo,

-- primo 7 == True

-- primo 8 == False

primo :: Integer -> Bool

primo x = [y | y <- [1..x], x `rem` y == 0] == [1,x]

-- primosImpares es la lista de los números primos impares. Por ejemplo,

-- take 10 primosImpares == [3,5,7,11,13,17,19,23,29]

primosImpares :: [Integer]

primosImpares = [x | x <- [3,5..], primo x]

-- (capicua x) se verifica si x es capicúa. Por ejemplo,

capicua :: Integer -> Bool

capicua x = ys == reverse ys

where ys = show x

-- 2ª solución

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

primosConsecutivosConMediaCapicua2 :: [(Integer,Integer,Integer)]

primosConsecutivosConMediaCapicua2 =

[(x,y,z) | (x,y) <- zip primosImpares2 (tail primosImpares2),

let z = (x + y) `div` 2,

capicua z]

primosImpares2 :: [Integer]

primosImpares2 = tail (criba [2..])

where criba (p:ps) = p : criba [n | n <- ps, mod n p /= 0]

criba [] = error "Imposible"

-- 3ª solución

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

primosConsecutivosConMediaCapicua3 :: [(Integer,Integer,Integer)]

primosConsecutivosConMediaCapicua3 =

[(x,y,z) | (x,y) <- zip (tail primos3) (drop 2 primos3),

let z = (x + y) `div` 2,

capicua z]

primos3 :: [Integer]

primos3 = 2 : 3 : criba3 0 (tail primos3) 3

where criba3 k (p:ps) x = [n | n <- [x+2,x+4..p*p-2],

and [n `rem` q /= 0 | q <- take k (tail primos3)]]

++ criba3 (k+1) ps (p*p)

criba3 _ [] _ = error "Imposible"

-- 4ª solución

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

primosConsecutivosConMediaCapicua4 :: [(Integer,Integer,Integer)]

primosConsecutivosConMediaCapicua4 =

[(x,y,z) | (x,y) <- zip (tail primes) (drop 2 primes),

let z = (x + y) `div` 2,

capicua z]

-- Equivalencia de definiciones

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

-- La propiedad es

prop_primosConsecutivosConMediaCapicua :: Integer -> Bool

prop_primosConsecutivosConMediaCapicua n =

all (== genericTake n primosConsecutivosConMediaCapicua)

[genericTake n primosConsecutivosConMediaCapicua2,

genericTake n primosConsecutivosConMediaCapicua3,

genericTake n primosConsecutivosConMediaCapicua4]

-- La comprobación es

-- λ> prop_primosConsecutivosConMediaCapicua 25 {-# SCC "" #-}

-- True

-- Comparación de eficiencia

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

-- La comparación es

-- λ> primosConsecutivosConMediaCapicua !! 30

-- (12919,12923,12921)

-- (4.60 secs, 1,877,064,288 bytes)

-- λ> primosConsecutivosConMediaCapicua2 !! 30

-- (12919,12923,12921)

-- (0.69 secs, 407,055,848 bytes)

-- λ> primosConsecutivosConMediaCapicua3 !! 30

-- (12919,12923,12921)

-- (0.07 secs, 18,597,104 bytes)

-- λ> primosConsecutivosConMediaCapicua4 !! 30

-- (12919,12923,12921)

-- (0.01 secs, 10,065,784 bytes)

-- λ> primosConsecutivosConMediaCapicua2 !! 40

-- (29287,29297,29292)

-- (2.67 secs, 1,775,554,576 bytes)

-- λ> primosConsecutivosConMediaCapicua3 !! 40

-- (29287,29297,29292)

-- (0.09 secs, 32,325,808 bytes)

-- λ> primosConsecutivosConMediaCapicua4 !! 40

-- (29287,29297,29292)

-- (0.01 secs, 22,160,072 bytes)

-- λ> primosConsecutivosConMediaCapicua3 !! 150

-- (605503,605509,605506)

-- (3.68 secs, 2,298,403,864 bytes)

-- λ> primosConsecutivosConMediaCapicua4 !! 150

-- (605503,605509,605506)

-- (0.24 secs, 491,917,240 bytes)

El código se encuentra en GitHub.

Mastermind

PorJosé A. Alonso 22-febrero-20221-marzo-2022

El Mastermind es un juego que consiste en deducir un código numérico formado por una lista de números. Cada vez que se empieza una partida, el programa debe elegir un código, que será lo que el jugador debe adivinar en la menor cantidad de intentos posibles. Cada intento consiste en una propuesta de un código posible que propone el jugador, y una respuesta del programa. Las respuestas le darán pistas al jugador para que pueda deducir el código.

Estas pistas indican lo cerca que estuvo el número propuesto de solución a través de dos valores: la cantidad de aciertos es la cantidad de dígitos que propuso el jugador que también están en el código en la misma posición. La cantidad de coincidencias es la cantidad de dígitos que propuso el jugador que también están en el código pero en una posición distinta.

Por ejemplo, si el código que eligió el programa es el [2,6,0,7] el jugador propone el [1,4,0,6], el programa le debe responder acierto (el 0, que está en el código original en el mismo lugar, tercero), y una coincidencia (el 6, que también está en el original, pero en la segunda posición, no en el cuarto como fue propuesto). Si el jugador hubiera propuesto el [3,5,9,1], habría obtenido como respuesta ningún acierto y ninguna coincidencia, ya que no hay números en común con el código original. Si se obtienen cuatro aciertos es porque el jugador adivinó el código y ganó el juego.

Definir la función

   mastermind :: [Int] -> [Int] -> (Int,Int)

1	mastermind :: [Int] -> [Int] -> (Int,Int)

tal que (mastermind xs ys) es el par formado por los números de aciertos y de coincidencias entre xs e ys. Por ejemplo,

   mastermind [3,3] [3,2]          ==  (1,0)
   mastermind [3,5,3] [3,2,5]      ==  (1,1)
   mastermind [3,5,3,2] [3,2,5,3]  ==  (1,3)
   mastermind [3,5,3,3] [3,2,5,3]  ==  (2,1)
   mastermind [1..10^6] [1..10^6]  ==  (1000000,0)

mastermind [3,3] [3,2] == (1,0)

mastermind [3,5,3] [3,2,5] == (1,1)

mastermind [3,5,3,2] [3,2,5,3] == (1,3)

mastermind [3,5,3,3] [3,2,5,3] == (2,1)

mastermind [1..10^6] [1..10^6] == (1000000,0)

Soluciones

import qualified Data.Set as S
import Test.QuickCheck (quickCheck)

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

mastermind :: [Int] -> [Int] -> (Int, Int)
mastermind xs ys =
  (length (aciertos xs ys), length (coincidencias xs ys))

-- (aciertos xs ys) es la lista de las posiciones de los aciertos entre
-- xs e ys. Por ejemplo,
--    aciertos [1,1,0,7] [1,0,1,7]  ==  [0,3]
aciertos :: Eq a => [a] -> [a] -> [Int]
aciertos xs ys =
  [n | (n,x,y) <- zip3 [0..] xs ys, x == y]

-- (coincidencia xs ys) es la lista de las posiciones de las
-- coincidencias entre xs e ys. Por ejemplo,
--    coincidencias [1,1,0,7] [1,0,1,7]  ==  [1,2]
coincidencias :: Eq a => [a] -> [a] -> [Int]
coincidencias xs ys =
  [n | (n,y) <- zip [0..] ys,
       y `elem` xs,
       n `notElem` aciertos xs ys]

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

mastermind2 :: [Int] -> [Int] -> (Int, Int)
mastermind2 xs ys =
  (length aciertos2, length coincidencias2)
  where
    aciertos2, coincidencias2 :: [Int]
    aciertos2      = [n | (n,x,y) <- zip3 [0..] xs ys, x == y]
    coincidencias2 = [n | (n,y) <- zip [0..] ys, y `elem` xs, n `notElem` aciertos2]

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

mastermind3 :: [Int] -> [Int] -> (Int, Int)
mastermind3 xs ys = aux xs ys
  where aux (u:us) (v:vs)
          | u == v      = (a+1,b)
          | v `elem` xs = (a,b+1)
          | otherwise   = (a,b)
          where (a,b) = aux us vs
        aux _ _ = (0,0)

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

mastermind4 :: [Int] -> [Int] -> (Int, Int)
mastermind4 xs ys =
  (length aciertos4, length coincidencias4)
  where
    aciertos4, coincidencias4 :: [Int]
    aciertos4      = [n | (n,x,y) <- zip3 [0..] xs ys, x == y]
    xs'            = S.fromList xs
    coincidencias4 = [n | (n,y) <- zip [0..] ys, y `S.member` xs', n `notElem` aciertos4]

-- Equivalencia de las definiciones
-- ================================

-- La propiedad es
prop_mastermind :: [Int] -> [Int] -> Bool
prop_mastermind xs ys =
  all (== mastermind xs1 ys1)
      [mastermind2 xs1 ys1,
       mastermind3 xs1 ys1,
       mastermind4 xs1 ys1]
  where n   = min (length xs) (length ys)
        xs1 = take n xs
        ys1 = take n ys

verifica_mastermind :: IO ()
verifica_mastermind = quickCheck prop_mastermind

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

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

-- La comparación es
--    λ> mastermind [1..10^4] (map (*2) [1..10^4])
--    (0,5000)
--    (14.17 secs, 11,209,750,408 bytes)
--    λ> mastermind2 [1..10^4] (map (*2) [1..10^4])
--    (0,5000)
--    (0.83 secs, 8,190,200 bytes)
--    λ> mastermind3 [1..10^4] (map (*2) [1..10^4])
--    (0,5000)
--    (0.61 secs, 7,339,232 bytes)
--    λ> mastermind4 [1..10^4] (map (*2) [1..10^4])
--    (0,5000)
--    (0.03 secs, 8,910,128 bytes)

import qualified Data.Set as S

import Test.QuickCheck (quickCheck)

-- 1ª solución

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

mastermind :: [Int] -> [Int] -> (Int, Int)

mastermind xs ys =

(length (aciertos xs ys), length (coincidencias xs ys))

-- (aciertos xs ys) es la lista de las posiciones de los aciertos entre

-- xs e ys. Por ejemplo,

-- aciertos [1,1,0,7] [1,0,1,7] == [0,3]

aciertos :: Eq a => [a] -> [a] -> [Int]

aciertos xs ys =

[n | (n,x,y) <- zip3 [0..] xs ys, x == y]

-- (coincidencia xs ys) es la lista de las posiciones de las

-- coincidencias entre xs e ys. Por ejemplo,

-- coincidencias [1,1,0,7] [1,0,1,7] == [1,2]

coincidencias :: Eq a => [a] -> [a] -> [Int]

coincidencias xs ys =

[n | (n,y) <- zip [0..] ys,

y `elem` xs,

n `notElem` aciertos xs ys]

-- 2ª solución

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

mastermind2 :: [Int] -> [Int] -> (Int, Int)

mastermind2 xs ys =

(length aciertos2, length coincidencias2)

where

aciertos2, coincidencias2 :: [Int]

aciertos2 = [n | (n,x,y) <- zip3 [0..] xs ys, x == y]

coincidencias2 = [n | (n,y) <- zip [0..] ys, y `elem` xs, n `notElem` aciertos2]

-- 3ª solución

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

mastermind3 :: [Int] -> [Int] -> (Int, Int)

mastermind3 xs ys = aux xs ys

where aux (u:us) (v:vs)

| u == v = (a+1,b)

| v `elem` xs = (a,b+1)

| otherwise = (a,b)

where (a,b) = aux us vs

aux _ _ = (0,0)

-- 4ª solución

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

mastermind4 :: [Int] -> [Int] -> (Int, Int)

mastermind4 xs ys =

(length aciertos4, length coincidencias4)

where

aciertos4, coincidencias4 :: [Int]

aciertos4 = [n | (n,x,y) <- zip3 [0..] xs ys, x == y]

xs' = S.fromList xs

coincidencias4 = [n | (n,y) <- zip [0..] ys, y `S.member` xs', n `notElem` aciertos4]

-- Equivalencia de las definiciones

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

-- La propiedad es

prop_mastermind :: [Int] -> [Int] -> Bool

prop_mastermind xs ys =

all (== mastermind xs1 ys1)

[mastermind2 xs1 ys1,

mastermind3 xs1 ys1,

mastermind4 xs1 ys1]

where n = min (length xs) (length ys)

xs1 = take n xs

ys1 = take n ys

verifica_mastermind :: IO ()

verifica_mastermind = quickCheck prop_mastermind

-- La comprobación es

-- λ> verifica_mastermind

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> mastermind [1..10^4] (map (*2) [1..10^4])

-- (0,5000)

-- (14.17 secs, 11,209,750,408 bytes)

-- λ> mastermind2 [1..10^4] (map (*2) [1..10^4])

-- (0,5000)

-- (0.83 secs, 8,190,200 bytes)

-- λ> mastermind3 [1..10^4] (map (*2) [1..10^4])

-- (0,5000)

-- (0.61 secs, 7,339,232 bytes)

-- λ> mastermind4 [1..10^4] (map (*2) [1..10^4])

-- (0,5000)

-- (0.03 secs, 8,910,128 bytes)

El código se encuentra en GitHub.

Determinación de los elementos minimales

PorJosé A. Alonso 21-febrero-202215-abril-2022

Definir la función

   minimales :: Ord a => [[a]] -> [[a]]

1	minimales :: Ord a => [[a]] -> [[a]]

tal que (minimales xss) es la lista de los elementos de xss que no están contenidos en otros elementos de xss. Por ejemplo,

   minimales [[1,3],[2,3,1],[3,2,5]]        ==  [[2,3,1],[3,2,5]]
   minimales [[1,3],[2,3,1],[3,2,5],[3,1]]  ==  [[2,3,1],[3,2,5]]
   map sum (minimales [[1..n] | n <- [1..300]])  ==  [45150]

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

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

map sum (minimales [[1..n] | n <- [1..300]]) == [45150]

Soluciones

import Data.List (delete, nub)
import Test.QuickCheck (quickCheck)

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

minimales :: Ord a => [[a]] -> [[a]]
minimales xss =
  [xs | xs <- xss,
        null [ys | ys <- xss, subconjuntoPropio xs ys]]

-- (subconjuntoPropio xs ys) se verifica si xs es un subconjunto propio
-- de ys. Por ejemplo,
--    subconjuntoPropio [1,3] [3,1,3]    ==  False
--    subconjuntoPropio [1,3,1] [3,1,2]  ==  True
subconjuntoPropio :: Ord a => [a] -> [a] -> Bool
subconjuntoPropio xs ys = aux (nub xs) (nub ys)
  where
    aux _       []  = False
    aux []      _   = True
    aux (u:us) vs = u `elem` vs && aux us (delete u vs)

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

minimales2 :: Ord a => [[a]] -> [[a]]
minimales2 xss =
  [xs | xs <- xss,
        null [ys | ys <- xss, subconjuntoPropio2 xs ys]]

subconjuntoPropio2 :: Ord a => [a] -> [a] -> Bool
subconjuntoPropio2 xs ys =
  subconjunto xs ys && not (subconjunto ys xs)

-- (subconjunto xs ys) se verifica si xs es un subconjunto de ys. Por
-- ejemplo,
--    subconjunto [1,3] [3,1,3]        ==  True
--    subconjunto [1,3,1,3] [3,1,3]    ==  True
--    subconjunto [1,3,2,3] [3,1,3]    ==  False
--    subconjunto [1,3,1,3] [3,1,3,2]  ==  True
subconjunto :: Ord a => [a] -> [a] -> Bool
subconjunto xs ys =
  all (`elem` ys) xs

-- Equivalencia de las definiciones
-- ================================

-- La propiedad es
prop_minimales :: [[Int]] -> Bool
prop_minimales xss =
   minimales xss == minimales2 xss

verifica_minimales :: IO ()
verifica_minimales =
  quickCheck prop_minimales

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

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

-- La comparación es
--    λ> length (minimales [[1..n] | n <- [1..200]])
--    1
--    (2.30 secs, 657,839,560 bytes)
--    λ> length (minimales2 [[1..n] | n <- [1..200]])
--    1
--    (0.84 secs, 101,962,480 bytes)

import Data.List (delete, nub)

import Test.QuickCheck (quickCheck)

-- 1ª solución

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

minimales :: Ord a => [[a]] -> [[a]]

minimales xss =

[xs | xs <- xss,

null [ys | ys <- xss, subconjuntoPropio xs ys]]

-- (subconjuntoPropio xs ys) se verifica si xs es un subconjunto propio

-- de ys. Por ejemplo,

-- subconjuntoPropio [1,3] [3,1,3] == False

-- subconjuntoPropio [1,3,1] [3,1,2] == True

subconjuntoPropio :: Ord a => [a] -> [a] -> Bool

subconjuntoPropio xs ys = aux (nub xs) (nub ys)

where

aux _ [] = False

aux [] _ = True

aux (u:us) vs = u `elem` vs && aux us (delete u vs)

-- 2ª solución

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

minimales2 :: Ord a => [[a]] -> [[a]]

minimales2 xss =

[xs | xs <- xss,

null [ys | ys <- xss, subconjuntoPropio2 xs ys]]

subconjuntoPropio2 :: Ord a => [a] -> [a] -> Bool

subconjuntoPropio2 xs ys =

subconjunto xs ys && not (subconjunto ys xs)

-- (subconjunto xs ys) se verifica si xs es un subconjunto de ys. Por

-- ejemplo,

-- subconjunto [1,3] [3,1,3] == True

-- subconjunto [1,3,1,3] [3,1,3] == True

-- subconjunto [1,3,2,3] [3,1,3] == False

-- subconjunto [1,3,1,3] [3,1,3,2] == True

subconjunto :: Ord a => [a] -> [a] -> Bool

subconjunto xs ys =

all (`elem` ys) xs

-- Equivalencia de las definiciones

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

-- La propiedad es

prop_minimales :: [[Int]] -> Bool

prop_minimales xss =

minimales xss == minimales2 xss

verifica_minimales :: IO ()

verifica_minimales =

quickCheck prop_minimales

-- La comprobación es

-- λ> verifica_minimales

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> length (minimales [[1..n] | n <- [1..200]])

-- 1

-- (2.30 secs, 657,839,560 bytes)

-- λ> length (minimales2 [[1..n] | n <- [1..200]])

-- 1

-- (0.84 secs, 101,962,480 bytes)

El código se encuentra en GitHub.

Máxima suma de caminos en un triángulo

PorJosé A. Alonso 15-febrero-202223-febrero-2022

Los triángulos se pueden representar mediante listas de listas. Por ejemplo, el triángulo

7 4

2 4 6

8 5 9 3

se reperesenta por

   [[3],[7,4],[2,4,6],[8,5,9,3]]

1	[[3],[7,4],[2,4,6],[8,5,9,3]]

Definir la función

   maximaSuma :: [[Integer]] -> Integer

1	maximaSuma :: [[Integer]] -> Integer

tal que (maximaSuma xss) es el máximo de las sumas de los elementos de los caminos en el triángulo xss donde los caminos comienzan en el elemento de la primera fila, en cada paso se mueve a uno de sus dos elementos adyacentes en la fila siguiente y terminan en la última fila. Por ejemplo,

   maximaSuma [[3],[7,4]]                    ==  10
   maximaSuma [[3],[7,4],[2,4,6]]            ==  14
   maximaSuma [[3],[7,4],[2,4,6],[8,5,9,3]]  ==  23
   maximaSuma [[n..n+n] | n <- [0..100]]     ==  10100
   maximaSuma [[n..n+n] | n <- [0..1000]]    ==  1001000
   maximaSuma [[n..n+n] | n <- [0..2000]]    ==  4002000
   maximaSuma [[n..n+n] | n <- [0..3000]]    ==  9003000
   maximaSuma [[n..n+n] | n <- [0..4000]]    ==  16004000

maximaSuma [[3],[7,4]] == 10

maximaSuma [[3],[7,4],[2,4,6]] == 14

maximaSuma [[3],[7,4],[2,4,6],[8,5,9,3]] == 23

maximaSuma [[n..n+n] | n <- [0..100]] == 10100

maximaSuma [[n..n+n] | n <- [0..1000]] == 1001000

maximaSuma [[n..n+n] | n <- [0..2000]] == 4002000

maximaSuma [[n..n+n] | n <- [0..3000]] == 9003000

maximaSuma [[n..n+n] | n <- [0..4000]] == 16004000

Soluciones

import Data.List (tails)

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

maximaSuma1 :: [[Integer]] -> Integer
maximaSuma1 xss =
  maximum [sum ys | ys <- caminos xss]

caminos :: [[Integer]] -> [[Integer]]
caminos []    = [[]]
caminos [[x]] = [[x]]
caminos ([x]:[y1,y2]:zs) =
  [x:y1:us | (_:us) <- caminos ([y1] : map init zs)] ++
  [x:y2:vs | (_:vs) <- caminos ([y2] : map tail zs)]

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

maximaSuma2 :: [[Integer]] -> Integer
maximaSuma2 xss = maximum (map sum (caminos xss))

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

maximaSuma3 :: [[Integer]] -> Integer
maximaSuma3 = maximum . map sum . caminos

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

maximaSuma4 :: [[Integer]] -> Integer
maximaSuma4 []    = 0
maximaSuma4 [[x]] = x
maximaSuma4 ([x]:[y1,y2]:zs) =
  x + max (maximaSuma4 ([y1] : map init zs))
          (maximaSuma4 ([y2] : map tail zs))

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

maximaSuma5 :: [[Integer]] -> Integer
maximaSuma5 xss = head (foldr1 g xss)
  where
    f x y z = x + max y z
    g xs ys = zipWith3 f xs ys (tail ys)

-- 6ª solución
-- ===========

maximaSuma6 :: [[Integer]] -> Integer
maximaSuma6 xss = head (foldr1 aux xss)
  where aux a b = zipWith (+) a (zipWith max b (tail b))

-- 7ª solución
-- ===========

maximaSuma7 :: [[Integer]] -> Integer
maximaSuma7 xss = head (foldr (flip f) (last xss) (init xss))
  where f = zipWith ((+) . maximum . take 2) . tails

-- 8ª solución
-- ===========

maximaSuma8 :: [[Integer]] -> Integer
maximaSuma8 = head . foldr1 aux
  where
    aux [] _              = []
    aux (x:xs) (y0:y1:ys) = x + max y0 y1 : aux xs (y1:ys)

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

-- Para la comparaciones se usará la siguiente función que construye un
-- triángulo de la altura dada. Por ejemplo,
--    triangulo 2  ==  [[0],[1,2]]
--    triangulo 3  ==  [[0],[1,2],[2,3,4]]
--    triangulo 4  ==  [[0],[1,2],[2,3,4],[3,4,5,6]]
triangulo :: Integer -> [[Integer]]
triangulo n = [[k..k+k] | k <- [0..n-1]]

-- La comparación es
--    (1.97 secs, 876,483,056 bytes)
--    λ> maximaSuma1 (triangulo 19)
--    342
--    (2.37 secs, 1,833,637,824 bytes)
--    λ> maximaSuma2 (triangulo 19)
--    342
--    (2.55 secs, 1,804,276,472 bytes)
--    λ> maximaSuma3 (triangulo 19)
--    342
--    (2.57 secs, 1,804,275,320 bytes)
--    λ> maximaSuma4 (triangulo 19)
--    342
--    (0.28 secs, 245,469,384 bytes)
--    λ> maximaSuma5 (triangulo 19)
--    342
--    (0.01 secs, 153,272 bytes)
--    λ> maximaSuma6 (triangulo 19)
--    342
--    (0.01 secs, 161,360 bytes)
--    λ> maximaSuma7 (triangulo 19)
--    342
--    (0.01 secs, 187,456 bytes)
--    λ> maximaSuma8 (triangulo 19)
--    342
--    (0.01 secs, 191,160 bytes)
--
--    λ> maximaSuma4 (triangulo 22)
--    462
--    (2.30 secs, 1,963,037,888 bytes)
--    λ> maximaSuma5 (triangulo 22)
--    462
--    (0.00 secs, 173,512 bytes)
--    λ> maximaSuma6 (triangulo 22)
--    462
--    (0.01 secs, 182,904 bytes)
--    λ> maximaSuma7 (triangulo 22)
--    462
--    (0.01 secs, 216,560 bytes)
--    λ> maximaSuma8 (triangulo 22)
--    462
--    (0.01 secs, 224,160 bytes)
--
--    λ> maximaSuma5 (triangulo 3000)
--    8997000
--    (2.25 secs, 2,059,784,792 bytes)
--    λ> maximaSuma6 (triangulo 3000)
--    8997000
--    (2.15 secs, 2,404,239,896 bytes)
--    λ> maximaSuma7 (triangulo 3000)
--    8997000
--    (1.53 secs, 2,612,659,504 bytes)
--    λ> maximaSuma8 (triangulo 3000)
--    8997000
--    (3.47 secs, 3,520,910,256 bytes)
--
--    λ> maximaSuma7 (triangulo 4000)
--    15996000
--    (3.12 secs, 4,634,841,200 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

import Data.List (tails)

-- 1ª solución

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

maximaSuma1 :: [[Integer]] -> Integer

maximaSuma1 xss =

maximum [sum ys | ys <- caminos xss]

caminos :: [[Integer]] -> [[Integer]]

caminos [] = [[]]

caminos [[x]] = [[x]]

caminos ([x]:[y1,y2]:zs) =

[x:y1:us | (_:us) <- caminos ([y1] : map init zs)] ++

[x:y2:vs | (_:vs) <- caminos ([y2] : map tail zs)]

-- 2ª solución

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

maximaSuma2 :: [[Integer]] -> Integer

maximaSuma2 xss = maximum (map sum (caminos xss))

-- 3ª solución

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

maximaSuma3 :: [[Integer]] -> Integer

maximaSuma3 = maximum . map sum . caminos

-- 4ª solución

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

maximaSuma4 :: [[Integer]] -> Integer

maximaSuma4 [] = 0

maximaSuma4 [[x]] = x

maximaSuma4 ([x]:[y1,y2]:zs) =

x + max (maximaSuma4 ([y1] : map init zs))

(maximaSuma4 ([y2] : map tail zs))

-- 5ª solución

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

maximaSuma5 :: [[Integer]] -> Integer

maximaSuma5 xss = head (foldr1 g xss)

where

f x y z = x + max y z

g xs ys = zipWith3 f xs ys (tail ys)

-- 6ª solución

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

maximaSuma6 :: [[Integer]] -> Integer

maximaSuma6 xss = head (foldr1 aux xss)

where aux a b = zipWith (+) a (zipWith max b (tail b))

-- 7ª solución

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

maximaSuma7 :: [[Integer]] -> Integer

maximaSuma7 xss = head (foldr (flip f) (last xss) (init xss))

where f = zipWith ((+) . maximum . take 2) . tails

-- 8ª solución

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

maximaSuma8 :: [[Integer]] -> Integer

maximaSuma8 = head . foldr1 aux

where

aux [] _ = []

aux (x:xs) (y0:y1:ys) = x + max y0 y1 : aux xs (y1:ys)

-- Comparación de eficiencia

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

-- Para la comparaciones se usará la siguiente función que construye un

-- triángulo de la altura dada. Por ejemplo,

-- triangulo 2 == [[0],[1,2]]

-- triangulo 3 == [[0],[1,2],[2,3,4]]

-- triangulo 4 == [[0],[1,2],[2,3,4],[3,4,5,6]]

triangulo :: Integer -> [[Integer]]

triangulo n = [[k..k+k] | k <- [0..n-1]]

-- La comparación es

-- (1.97 secs, 876,483,056 bytes)

-- λ> maximaSuma1 (triangulo 19)

-- 342

-- (2.37 secs, 1,833,637,824 bytes)

-- λ> maximaSuma2 (triangulo 19)

-- 342

-- (2.55 secs, 1,804,276,472 bytes)

-- λ> maximaSuma3 (triangulo 19)

-- 342

-- (2.57 secs, 1,804,275,320 bytes)

-- λ> maximaSuma4 (triangulo 19)

-- 342

-- (0.28 secs, 245,469,384 bytes)

-- λ> maximaSuma5 (triangulo 19)

-- 342

-- (0.01 secs, 153,272 bytes)

-- λ> maximaSuma6 (triangulo 19)

-- 342

-- (0.01 secs, 161,360 bytes)

-- λ> maximaSuma7 (triangulo 19)

-- 342

-- (0.01 secs, 187,456 bytes)

-- λ> maximaSuma8 (triangulo 19)

-- 342

-- (0.01 secs, 191,160 bytes)

-- λ> maximaSuma4 (triangulo 22)

-- 462

-- (2.30 secs, 1,963,037,888 bytes)

-- λ> maximaSuma5 (triangulo 22)

-- 462

-- (0.00 secs, 173,512 bytes)

-- λ> maximaSuma6 (triangulo 22)

-- 462

-- (0.01 secs, 182,904 bytes)

-- λ> maximaSuma7 (triangulo 22)

-- 462

-- (0.01 secs, 216,560 bytes)

-- λ> maximaSuma8 (triangulo 22)

-- 462

-- (0.01 secs, 224,160 bytes)

-- λ> maximaSuma5 (triangulo 3000)

-- 8997000

-- (2.25 secs, 2,059,784,792 bytes)

-- λ> maximaSuma6 (triangulo 3000)

-- 8997000

-- (2.15 secs, 2,404,239,896 bytes)

-- λ> maximaSuma7 (triangulo 3000)

-- 8997000

-- (1.53 secs, 2,612,659,504 bytes)

-- λ> maximaSuma8 (triangulo 3000)

-- 8997000

-- (3.47 secs, 3,520,910,256 bytes)

-- λ> maximaSuma7 (triangulo 4000)

-- 15996000

-- (3.12 secs, 4,634,841,200 bytes)

El código se encuentra en GitHub.

Caminos en un triángulo

PorJosé A. Alonso 14-febrero-202223-febrero-2022

Los triángulos se pueden representar mediante listas de listas. Por ejemplo, el triángulo

7 4

2 4 6

8 5 9 3

se representa por

   [[3],[7,4],[2,4,6],[8,5,9,3]]

1	[[3],[7,4],[2,4,6],[8,5,9,3]]

Definir la función

   caminos :: [[a]] -> [[a]]

1	caminos :: [[a]] -> [[a]]

tal que (caminos xss) es la lista de los caminos en el triángulo xss donde los caminos comienzan en el elemento de la primera fila, en cada paso se mueve a uno de sus dos elementos adyacentes en la fila siguiente y terminan en la última fila. Por ejemplo,

   λ> caminos [[3],[7,4]]
   [[3,7],[3,4]]
   λ> caminos [[3],[7,4],[2,4,6]]
   [[3,7,2],[3,7,4],[3,4,4],[3,4,6]]
   λ> caminos [[3],[7,4],[2,4,6],[8,5,9,3]]
   [[3,7,2,8],[3,7,2,5],[3,7,4,5],[3,7,4,9],[3,4,4,5],[3,4,4,9],[3,4,6,9],[3,4,6,3]]

λ> caminos [[3],[7,4]]

[[3,7],[3,4]]

λ> caminos [[3],[7,4],[2,4,6]]

[[3,7,2],[3,7,4],[3,4,4],[3,4,6]]

λ> caminos [[3],[7,4],[2,4,6],[8,5,9,3]]

[[3,7,2,8],[3,7,2,5],[3,7,4,5],[3,7,4,9],[3,4,4,5],[3,4,4,9],[3,4,6,9],[3,4,6,3]]

Soluciones

caminos :: [[a]] -> [[a]]
caminos []    = [[]]
caminos [[x]] = [[x]]
caminos ([x]:[y1,y2]:zs) =
  [x:y1:us | (_:us) <- caminos ([y1] : map init zs)] ++
  [x:y2:vs | (_:vs) <- caminos ([y2] : map tail zs)]

caminos :: [[a]] -> [[a]]

caminos [] = [[]]

caminos [[x]] = [[x]]

caminos ([x]:[y1,y2]:zs) =

[x:y1:us | (_:us) <- caminos ([y1] : map init zs)] ++

[x:y2:vs | (_:vs) <- caminos ([y2] : map tail zs)]

El código se encuentra en GitHub.

Mayor órbita de la sucesión de Collatz

PorJosé A. Alonso 11-febrero-202215-abril-2022

Se considera la siguiente operación, aplicable a cualquier número entero positivo:

Si el número es par, se divide entre 2.
Si el número es impar, se multiplica por 3 y se suma 1.

Dado un número cualquiera, podemos calcular su órbita; es decir, las imágenes sucesivas al iterar la función. Por ejemplo, la órbita de 13 es

   13, 40, 20, 10, 5, 16, 8, 4, 2, 1, 4, 2, 1,...

1	13, 40, 20, 10, 5, 16, 8, 4, 2, 1, 4, 2, 1,...

Si observamos este ejemplo, la órbita de 13 es periódica, es decir, se repite indefinidamente a partir de un momento dado). La conjetura de Collatz dice que siempre alcanzaremos el 1 para cualquier número con el que comencemos. Por ejemplo,

Empezando en n = 6 se obtiene 6, 3, 10, 5, 16, 8, 4, 2, 1.
Empezando en n = 11 se obtiene: 11, 34, 17, 52, 26, 13, 40, 20, 10, 5, 16, 8, 4, 2, 1.
Empezando en n = 27, la sucesión tiene 112 pasos, llegando hasta 9232 antes de descender a 1: 27, 82, 41, 124, 62, 31, 94, 47, 142, 71, 214, 107, 322, 161, 484, 242, 121, 364, 182, 91, 274, 137, 412, 206, 103, 310, 155, 466, 233, 700, 350, 175, 526, 263, 790, 395, 1186, 593, 1780, 890, 445, 1336, 668, 334, 167, 502, 251, 754, 377, 1132, 566, 283, 850, 425, 1276, 638, 319, 958, 479, 1438, 719, 2158, 1079, 3238, 1619, 4858, 2429, 7288, 3644, 1822, 911, 2734, 1367, 4102, 2051, 6154, 3077, 9232, 4616, 2308, 1154, 577, 1732, 866, 433, 1300, 650, 325, 976, 488, 244, 122, 61, 184, 92, 46, 23, 70, 35, 106, 53, 160, 80, 40, 20, 10, 5, 16, 8, 4, 2, 1.

Definir la función

   mayoresGeneradores :: Integer -> [Integer]

1	mayoresGeneradores :: Integer -> [Integer]

tal que (mayoresGeneradores n) es la lista de los números menores o iguales que n cuyas órbitas de Collatz son las de mayor longitud. Por ejemplo,

   mayoresGeneradores 20      ==  [18,19]
   mayoresGeneradores (10^6)  ==  [837799]

1 2	mayoresGeneradores 20 == [18,19] mayoresGeneradores (10^6) == [837799]

Soluciones

import qualified Data.MemoCombinators as Memo (integral)
import Data.List (genericLength, genericTake, maximumBy)
import Test.QuickCheck (Positive(..), quickCheck)

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

mayoresGeneradores :: Integer -> [Integer]
mayoresGeneradores n =
  [x | (x,y) <- ps, y == m]
  where ps = genericTake n longitudesOrbitas
        m  = maximum (map snd ps)

-- longitudesOrbita es la lista de los números junto a las longitudes de
-- las órbitas de Collatz que generan. Por ejemplo,
--    λ> take 10 longitudesOrbitas
--    [(1,1),(2,2),(3,8),(4,3),(5,6),(6,9),(7,17),(8,4),(9,20),(10,7)]
longitudesOrbitas :: [(Integer, Integer)]
longitudesOrbitas =
  [(n, genericLength (collatz n)) | n <- [1..]]

-- (siguiente n) es el siguiente de n en la sucesión de Collatz. Por
-- ejemplo,
--    siguiente 13  ==  40
--    siguiente 40  ==  20
siguiente :: Integer -> Integer
siguiente n | even n    = n `div` 2
            | otherwise = 3*n+1

-- (collatz1 n) es la órbita de Collatz de n hasta alcanzar el
-- 1. Por ejemplo,
--    collatz 13  ==  [13,40,20,10,5,16,8,4,2,1]

-- 1ª definición de collatz
collatz1 :: Integer -> [Integer]
collatz1 1 = [1]
collatz1 n = n : collatz1 (siguiente n)

-- 2ª definición de collatz
collatz2 :: Integer -> [Integer]
collatz2 n = takeWhile (/=1) (iterate siguiente n) ++ [1]

-- Usaremos la 2ª definición de collatz
collatz :: Integer -> [Integer]
collatz = collatz2

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

mayoresGeneradores2 :: Integer -> [Integer]
mayoresGeneradores2 n =
  [x | (x,y) <- ps, y == m]
  where ps = [(x, longitudOrbita x) | x <- [1..n]]
        m  = maximum (map snd ps)

-- (longitudOrbita x) es la longitud de la órbita de x. Por ejemplo,
--    longitudOrbita 13  ==  10
longitudOrbita :: Integer -> Integer
longitudOrbita 1 = 1
longitudOrbita x = 1 + longitudOrbita (siguiente x)

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

mayoresGeneradores3 :: Integer -> [Integer]
mayoresGeneradores3 n =
  [x | (x,y) <- ps, y == m]
  where ps = [(x, longitudOrbita2 x) | x <- [1..n]]
        m  = maximum (map snd ps)

longitudOrbita2 :: Integer -> Integer
longitudOrbita2 = Memo.integral longitudOrbita2'
  where
    longitudOrbita2' 1 = 1
    longitudOrbita2' x = 1 + longitudOrbita2 (siguiente x)


-- Equivalencia de definiciones
-- ============================

-- La propiedad es
prop_mayoresGeneradores :: (Positive Integer) -> Bool
prop_mayoresGeneradores (Positive n) =
  all (== (mayoresGeneradores n))
      [mayoresGeneradores2 n,
       mayoresGeneradores3 n]

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

-- Comprobación de eficiencia
-- ==========================

-- La comprobación es
--    λ> mayoresGeneradores (10^5)
--    [77031]
--    (5.43 secs, 6,232,320,064 bytes)
--    λ> mayoresGeneradores2 (10^5)
--    [77031]
--    (7.68 secs, 5,238,991,616 bytes)
--    λ> mayoresGeneradores3 (10^5)
--    [77031]
--    (0.88 secs, 571,788,736 bytes)

100

101

102

103

104

import qualified Data.MemoCombinators as Memo (integral)

import Data.List (genericLength, genericTake, maximumBy)

import Test.QuickCheck (Positive(..), quickCheck)

-- 1ª solución

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

mayoresGeneradores :: Integer -> [Integer]

mayoresGeneradores n =

[x | (x,y) <- ps, y == m]

where ps = genericTake n longitudesOrbitas

m = maximum (map snd ps)

-- longitudesOrbita es la lista de los números junto a las longitudes de

-- las órbitas de Collatz que generan. Por ejemplo,

-- λ> take 10 longitudesOrbitas

-- [(1,1),(2,2),(3,8),(4,3),(5,6),(6,9),(7,17),(8,4),(9,20),(10,7)]

longitudesOrbitas :: [(Integer, Integer)]

longitudesOrbitas =

[(n, genericLength (collatz n)) | n <- [1..]]

-- (siguiente n) es el siguiente de n en la sucesión de Collatz. Por

-- ejemplo,

-- siguiente 13 == 40

-- siguiente 40 == 20

siguiente :: Integer -> Integer

siguiente n | even n = n `div` 2

| otherwise = 3*n+1

-- (collatz1 n) es la órbita de Collatz de n hasta alcanzar el

-- 1. Por ejemplo,

-- collatz 13 == [13,40,20,10,5,16,8,4,2,1]

-- 1ª definición de collatz

collatz1 :: Integer -> [Integer]

collatz1 1 = [1]

collatz1 n = n : collatz1 (siguiente n)

-- 2ª definición de collatz

collatz2 :: Integer -> [Integer]

collatz2 n = takeWhile (/=1) (iterate siguiente n) ++ [1]

-- Usaremos la 2ª definición de collatz

collatz :: Integer -> [Integer]

collatz = collatz2

-- 2ª solución

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

mayoresGeneradores2 :: Integer -> [Integer]

mayoresGeneradores2 n =

[x | (x,y) <- ps, y == m]

where ps = [(x, longitudOrbita x) | x <- [1..n]]

m = maximum (map snd ps)

-- (longitudOrbita x) es la longitud de la órbita de x. Por ejemplo,

-- longitudOrbita 13 == 10

longitudOrbita :: Integer -> Integer

longitudOrbita 1 = 1

longitudOrbita x = 1 + longitudOrbita (siguiente x)

-- 3ª solución

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

mayoresGeneradores3 :: Integer -> [Integer]

mayoresGeneradores3 n =

[x | (x,y) <- ps, y == m]

where ps = [(x, longitudOrbita2 x) | x <- [1..n]]

m = maximum (map snd ps)

longitudOrbita2 :: Integer -> Integer

longitudOrbita2 = Memo.integral longitudOrbita2'

where

longitudOrbita2' 1 = 1

longitudOrbita2' x = 1 + longitudOrbita2 (siguiente x)

-- Equivalencia de definiciones

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

-- La propiedad es

prop_mayoresGeneradores :: (Positive Integer) -> Bool

prop_mayoresGeneradores (Positive n) =

all (== (mayoresGeneradores n))

[mayoresGeneradores2 n,

mayoresGeneradores3 n]

-- La comprobación es

-- λ> quickCheck prop_mayoresGeneradores

-- +++ OK, passed 100 tests.

-- Comprobación de eficiencia

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

-- La comprobación es

-- λ> mayoresGeneradores (10^5)

-- [77031]

-- (5.43 secs, 6,232,320,064 bytes)

-- λ> mayoresGeneradores2 (10^5)

-- [77031]

-- (7.68 secs, 5,238,991,616 bytes)

-- λ> mayoresGeneradores3 (10^5)

-- [77031]

-- (0.88 secs, 571,788,736 bytes)

El código se encuentra en GitHub.

Exponente en la factorización

PorJosé A. Alonso 8-febrero-202215-abril-2022

Definir la función

   exponente :: Integer -> Integer -> Int

1	exponente :: Integer -> Integer -> Int

tal que (exponente x n) es el exponente de x en la factorizacón prima de n (se supone que x > 1 y n > 0). Por ejemplo,

   exponente 2 24  ==  3
   exponente 3 24  ==  1
   exponente 6 24  ==  0
   exponente 7 24  ==  0

exponente 2 24 == 3

exponente 3 24 == 1

exponente 6 24 == 0

exponente 7 24 == 0

Soluciones

import Data.Numbers.Primes (primeFactors)
import Test.QuickCheck

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

exponente1 :: Integer -> Integer -> Int
exponente1 x n
  | esPrimo x = aux n
  | otherwise = 0
  where aux m | m `mod` x == 0 = 1 + aux (m `div` x)
              | otherwise      = 0

-- (esPrimo x) se verifica si x es un número primo. Por ejemplo,
--    esPrimo 7  ==  True
--    esPrimo 8  ==  False
esPrimo :: Integer -> Bool
esPrimo x =
  [y | y <- [1..x], x `mod` y == 0] == [1,x]

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

exponente2 :: Integer -> Integer -> Int
exponente2 x n
  | esPrimo x = length (takeWhile (`divisible` x) (iterate (`div` x) n))
  | otherwise = 0

-- (divisible n x) se verifica si ne divisible por x. Por ejemplo,
--    divisible 6 2  ==  True
--    divisible 7 2  ==  False
divisible :: Integer -> Integer -> Bool
divisible n x = n `mod` x == 0

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

exponente3 :: Integer -> Integer -> Int
exponente3 x n =
  length (filter (==x) (primeFactors n))

-- Equivalencia de las definiciones
-- ================================

-- La propiedad es
prop_exponente :: Integer -> Integer -> Property
prop_exponente x n =
  x > 1 && n > 0 ==>
  exponente1 x n == exponente2 x n &&
  exponente1 x n == exponente3 x n

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

import Data.Numbers.Primes (primeFactors)

import Test.QuickCheck

-- 1ª solución

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

exponente1 :: Integer -> Integer -> Int

exponente1 x n

| esPrimo x = aux n

| otherwise = 0

where aux m | m `mod` x == 0 = 1 + aux (m `div` x)

| otherwise = 0

-- (esPrimo x) se verifica si x es un número primo. Por ejemplo,

-- esPrimo 7 == True

-- esPrimo 8 == False

esPrimo :: Integer -> Bool

esPrimo x =

[y | y <- [1..x], x `mod` y == 0] == [1,x]

-- 2ª solución

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

exponente2 :: Integer -> Integer -> Int

exponente2 x n

| esPrimo x = length (takeWhile (`divisible` x) (iterate (`div` x) n))

| otherwise = 0

-- (divisible n x) se verifica si ne divisible por x. Por ejemplo,

-- divisible 6 2 == True

-- divisible 7 2 == False

divisible :: Integer -> Integer -> Bool

divisible n x = n `mod` x == 0

-- 3ª solución

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

exponente3 :: Integer -> Integer -> Int

exponente3 x n =

length (filter (==x) (primeFactors n))

-- Equivalencia de las definiciones

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

-- La propiedad es

prop_exponente :: Integer -> Integer -> Property

prop_exponente x n =

x > 1 && n > 0 ==>

exponente1 x n == exponente2 x n &&

exponente1 x n == exponente3 x n

-- La comprobación es

-- λ> quickCheck prop_exponente

-- +++ OK, passed 100 tests.

El código se encuentra en GitHub.

Número de ocurrencias de elementos

PorJosé A. Alonso 7-febrero-202223-febrero-2022

Definir la función

   ocurrenciasElementos :: Ord a => [a] -> [(a,Int)]

1	ocurrenciasElementos :: Ord a => [a] -> [(a,Int)]

tal que (ocurrencias xs) es el conjunto de los elementos de xs junto con sus números de ocurrencias. Por ejemplo,

   ocurrenciasElementos1 [3,2,3,1,2,3,5,3] == [(3,4),(2,2),(1,1),(5,1)]
   ocurrenciasElementos1 "tictac"          == [('t',2),('i',1),('c',2),('a',1)]

1 2	ocurrenciasElementos1 [3,2,3,1,2,3,5,3] == [(3,4),(2,2),(1,1),(5,1)] ocurrenciasElementos1 "tictac" == [('t',2),('i',1),('c',2),('a',1)]

Soluciones

import Data.List (group, nub, sort)
import Data.Maybe (fromJust)
import qualified Data.Map as M
import Test.QuickCheck

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

ocurrenciasElementos1 :: Ord a => [a] -> [(a,Int)]
ocurrenciasElementos1 xs =
  [(x,ocurrencias x xs) | x <- nub xs]

-- (ocurrencias x xs) es el número de ocurrencias de x en xs. Por
-- ejemplo,
--    ocurrencias 'a' "Salamanca"  ==  4
ocurrencias :: Ord a => a -> [a] -> Int
ocurrencias x xs = length (filter (==x) xs)

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

ocurrenciasElementos2 :: Ord a => [a] -> [(a,Int)]
ocurrenciasElementos2 xs = map ocurrencias (nub xs)
  where ocurrencias x = (x,fromJust (lookup x (frecuencias xs)))

-- (frecuencias xs) es la lista ordenada de los elementos de xs juntos
-- con sus números de ocurrencias. Por ejemplo,
--    frecuencias [3,2,3,1,2,3,5,3]  ==  [(1,1),(2,2),(3,4),(5,1)]
frecuencias :: Ord a => [a] -> [(a, Int)]
frecuencias xs = [(head ys, length ys) | ys <- group (sort xs)]

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

ocurrenciasElementos3 :: Ord a => [a] -> [(a,Int)]
ocurrenciasElementos3 xs = map ocurrencias (nub xs)
  where diccionario   = dicFrecuencias xs
        ocurrencias x = (x, diccionario M.! x)

-- (dicFrecuencias xs) es el diccionario de los elementos de xs juntos
-- con sus números de ocurrencias. Por ejemplo,
--    λ> dicFrecuencias [3,2,3,1,2,3,5,3]
--    fromList [(1,1),(2,2),(3,4),(5,1)]
dicFrecuencias :: Ord a => [a] -> M.Map a Int
dicFrecuencias xs = M.fromListWith (+) (zip xs (repeat 1))

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

ocurrenciasElementos4 :: Ord a => [a] -> [(a,Int)]
ocurrenciasElementos4 = foldl aux []
  where
    aux [] y                     = [(y,1)]
    aux ((x,k):xs) y | x == y    = (x, k + 1) : xs
                     | otherwise = (x, k) : aux xs y

-- Equivalencia de las definiciones
-- ================================

-- La propiedad es
prop_ocurrenciasElementos :: [Integer] -> Bool
prop_ocurrenciasElementos xs =
  all (== (ocurrenciasElementos1 xs))
      [f xs | f <- [ocurrenciasElementos2,
                    ocurrenciasElementos3,
                    ocurrenciasElementos4]]

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

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

-- La comparación es
--    λ> last (ocurrenciasElementos1 (show (product [1..10^5])))
--    ('5',42935)
--    (7.93 secs, 11,325,169,512 bytes)
--    λ> last (ocurrenciasElementos2 (show (product [1..10^5])))
--    ('5',42935)
--    (8.46 secs, 11,750,911,592 bytes)
--    λ> last (ocurrenciasElementos3 (show (product [1..10^5])))
--    ('5',42935)
--    (8.29 secs, 11,447,015,896 bytes)
--    λ> last (ocurrenciasElementos4 (show (product [1..10^5])))
--    ('5',42935)
--    (9.97 secs, 12,129,527,912 bytes)

import Data.List (group, nub, sort)

import Data.Maybe (fromJust)

import qualified Data.Map as M

import Test.QuickCheck

-- 1ª solución

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

ocurrenciasElementos1 :: Ord a => [a] -> [(a,Int)]

ocurrenciasElementos1 xs =

[(x,ocurrencias x xs) | x <- nub xs]

-- (ocurrencias x xs) es el número de ocurrencias de x en xs. Por

-- ejemplo,

-- ocurrencias 'a' "Salamanca" == 4

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

ocurrencias x xs = length (filter (==x) xs)

-- 2ª solución

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

ocurrenciasElementos2 :: Ord a => [a] -> [(a,Int)]

ocurrenciasElementos2 xs = map ocurrencias (nub xs)

where ocurrencias x = (x,fromJust (lookup x (frecuencias xs)))

-- (frecuencias xs) es la lista ordenada de los elementos de xs juntos

-- con sus números de ocurrencias. Por ejemplo,

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

frecuencias :: Ord a => [a] -> [(a, Int)]

frecuencias xs = [(head ys, length ys) | ys <- group (sort xs)]

-- 3ª solución

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

ocurrenciasElementos3 :: Ord a => [a] -> [(a,Int)]

ocurrenciasElementos3 xs = map ocurrencias (nub xs)

where diccionario = dicFrecuencias xs

ocurrencias x = (x, diccionario M.! x)

-- (dicFrecuencias xs) es el diccionario de los elementos de xs juntos

-- con sus números de ocurrencias. Por ejemplo,

-- λ> dicFrecuencias [3,2,3,1,2,3,5,3]

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

dicFrecuencias :: Ord a => [a] -> M.Map a Int

dicFrecuencias xs = M.fromListWith (+) (zip xs (repeat 1))

-- 4ª solución

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

ocurrenciasElementos4 :: Ord a => [a] -> [(a,Int)]

ocurrenciasElementos4 = foldl aux []

where

aux [] y = [(y,1)]

aux ((x,k):xs) y | x == y = (x, k + 1) : xs

| otherwise = (x, k) : aux xs y

-- Equivalencia de las definiciones

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

-- La propiedad es

prop_ocurrenciasElementos :: [Integer] -> Bool

prop_ocurrenciasElementos xs =

all (== (ocurrenciasElementos1 xs))

[f xs | f <- [ocurrenciasElementos2,

ocurrenciasElementos3,

ocurrenciasElementos4]]

-- La comprobación es

-- λ> quickCheck prop_ocurrenciasElementos

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> last (ocurrenciasElementos1 (show (product [1..10^5])))

-- ('5',42935)

-- (7.93 secs, 11,325,169,512 bytes)

-- λ> last (ocurrenciasElementos2 (show (product [1..10^5])))

-- ('5',42935)

-- (8.46 secs, 11,750,911,592 bytes)

-- λ> last (ocurrenciasElementos3 (show (product [1..10^5])))

-- ('5',42935)

-- (8.29 secs, 11,447,015,896 bytes)

-- λ> last (ocurrenciasElementos4 (show (product [1..10^5])))

-- ('5',42935)

-- (9.97 secs, 12,129,527,912 bytes)

El código se encuentra en GitHub.

Reconocimiento de potencias de 4

PorJosé A. Alonso 4-febrero-202215-abril-2022

Definir la función

   esPotenciaDe4 :: Integral a => a -> Bool

1	esPotenciaDe4 :: Integral a => a -> Bool

tal que (esPotenciaDe4 n) se verifica si n es una potencia de 4. Por ejemplo,

   esPotenciaDe4 16                ==  True
   esPotenciaDe4 17                ==  False
   esPotenciaDe4 (4^(4*10^5))      ==  True
   esPotenciaDe4 (1 + 4^(4*10^5))  ==  False

esPotenciaDe4 16 == True

esPotenciaDe4 17 == False

esPotenciaDe4 (4^(4*10^5)) == True

esPotenciaDe4 (1 + 4^(4*10^5)) == False

Soluciones

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

esPotenciaDe4_1 :: Integral a => a -> Bool
esPotenciaDe4_1 0 = False
esPotenciaDe4_1 1 = True
esPotenciaDe4_1 n = n `mod` 4 == 0 && esPotenciaDe4_1 (n `div` 4)

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

esPotenciaDe4_2 :: Integral a => a -> Bool
esPotenciaDe4_2 n = n `pertenece` potenciasDe4

-- potenciassDe4 es la lista de las potencias de 4. Por ejemplo,
--    take 5 potenciasDe4  ==  [1,4,16,64,256]
potenciasDe4 :: Integral a => [a]
potenciasDe4 = [4^x | x <- [0..]]

-- (pertenece x ys) se verifica si x pertenece a la lista ordenada
-- (posiblemente infinita xs). Por ejemplo,
--    pertenece 8 [2,4..]  ==  True
--    pertenece 9 [2,4..]  ==  False
pertenece :: Integral a => a -> [a] -> Bool
pertenece x ys = x == head (dropWhile (<x) ys)

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

esPotenciaDe4_3 :: Integral a => a -> Bool
esPotenciaDe4_3 n = n `pertenece` potenciasDe4_2

-- potenciassDe4 es la lista de las potencias de 4. Por ejemplo,
--    take 5 potenciasDe4  ==  [1,4,16,64,256]
potenciasDe4_2 :: Integral a => [a]
potenciasDe4_2 = iterate (*4) 1

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

esPotenciaDe4_4 :: Integral n => n -> Bool
esPotenciaDe4_4 n =
  n == head (dropWhile (<n) (iterate (*4) 1))

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

esPotenciaDe4_5 :: Integral n => n -> Bool
esPotenciaDe4_5 n =
  n == until (>=n) (*4) 1

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

-- La comparación es
--    λ> esPotenciaDe4_1 (4^(4*10^4))
--    True
--    (0.18 secs, 233,903,248 bytes)
--    λ> esPotenciaDe4_2 (4^(4*10^4))
--    True
--    (2.01 secs, 756,125,712 bytes)
--    λ> esPotenciaDe4_3 (4^(4*10^4))
--    True
--    (0.05 secs, 212,019,464 bytes)
--    λ> esPotenciaDe4_4 (4^(4*10^4))
--    True
--    (0.05 secs, 212,019,368 bytes)
--    λ> esPotenciaDe4_5 (4^(4*10^4))
--    True
--    (0.07 secs, 209,779,888 bytes)
--
--    λ> esPotenciaDe4_3 (4^(2*10^5))
--    True
--    (0.64 secs, 5,184,667,280 bytes)
--    λ> esPotenciaDe4_4 (4^(2*10^5))
--    True
--    (0.64 secs, 5,184,667,200 bytes)
--    λ> esPotenciaDe4_5 (4^(2*10^5))
--    True
--    (0.63 secs, 5,173,467,656 bytes)
--
--    λ> esPotenciaDe4_3 (4^(4*10^5))
--    True
--    (2.27 secs, 20,681,727,464 bytes)
--    λ> esPotenciaDe4_4 (4^(4*10^5))
--    True
--    (2.30 secs, 20,681,727,320 bytes)
--    λ> esPotenciaDe4_5 (4^(4*10^5))
--    True
--    (2.28 secs, 20,659,327,352 bytes)

-- 1ª solución

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

esPotenciaDe4_1 :: Integral a => a -> Bool

esPotenciaDe4_1 0 = False

esPotenciaDe4_1 1 = True

esPotenciaDe4_1 n = n `mod` 4 == 0 && esPotenciaDe4_1 (n `div` 4)

-- 2ª solución

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

esPotenciaDe4_2 :: Integral a => a -> Bool

esPotenciaDe4_2 n = n `pertenece` potenciasDe4

-- potenciassDe4 es la lista de las potencias de 4. Por ejemplo,

-- take 5 potenciasDe4 == [1,4,16,64,256]

potenciasDe4 :: Integral a => [a]

potenciasDe4 = [4^x | x <- [0..]]

-- (pertenece x ys) se verifica si x pertenece a la lista ordenada

-- (posiblemente infinita xs). Por ejemplo,

-- pertenece 8 [2,4..] == True

-- pertenece 9 [2,4..] == False

pertenece :: Integral a => a -> [a] -> Bool

pertenece x ys = x == head (dropWhile (<x) ys)

-- 3ª solución

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

esPotenciaDe4_3 :: Integral a => a -> Bool

esPotenciaDe4_3 n = n `pertenece` potenciasDe4_2

-- potenciassDe4 es la lista de las potencias de 4. Por ejemplo,

-- take 5 potenciasDe4 == [1,4,16,64,256]

potenciasDe4_2 :: Integral a => [a]

potenciasDe4_2 = iterate (*4) 1

-- 4ª solución

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

esPotenciaDe4_4 :: Integral n => n -> Bool

esPotenciaDe4_4 n =

n == head (dropWhile (<n) (iterate (*4) 1))

-- 5ª solución

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

esPotenciaDe4_5 :: Integral n => n -> Bool

esPotenciaDe4_5 n =

n == until (>=n) (*4) 1

-- Comparación de eficiencia

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

-- La comparación es

-- λ> esPotenciaDe4_1 (4^(4*10^4))

-- True

-- (0.18 secs, 233,903,248 bytes)

-- λ> esPotenciaDe4_2 (4^(4*10^4))

-- True

-- (2.01 secs, 756,125,712 bytes)

-- λ> esPotenciaDe4_3 (4^(4*10^4))

-- True

-- (0.05 secs, 212,019,464 bytes)

-- λ> esPotenciaDe4_4 (4^(4*10^4))

-- True

-- (0.05 secs, 212,019,368 bytes)

-- λ> esPotenciaDe4_5 (4^(4*10^4))

-- True

-- (0.07 secs, 209,779,888 bytes)

-- λ> esPotenciaDe4_3 (4^(2*10^5))

-- True

-- (0.64 secs, 5,184,667,280 bytes)

-- λ> esPotenciaDe4_4 (4^(2*10^5))

-- True

-- (0.64 secs, 5,184,667,200 bytes)

-- λ> esPotenciaDe4_5 (4^(2*10^5))

-- True

-- (0.63 secs, 5,173,467,656 bytes)

-- λ> esPotenciaDe4_3 (4^(4*10^5))

-- True

-- (2.27 secs, 20,681,727,464 bytes)

-- λ> esPotenciaDe4_4 (4^(4*10^5))

-- True

-- (2.30 secs, 20,681,727,320 bytes)

-- λ> esPotenciaDe4_5 (4^(4*10^5))

-- True

-- (2.28 secs, 20,659,327,352 bytes)

El código se encuentra en GitHub.

Producto de los elementos de la diagonal principal

PorJosé A. Alonso 3-febrero-202215-abril-2022

Las matrices se pueden representar como lista de listas de la misma longitud, donde cada uno de sus elementos representa una fila de la matriz.

Definir la función

   productoDiagonalPrincipal :: Num a => [[a]] -> a

1	productoDiagonalPrincipal :: Num a => [[a]] -> a

tal que (productoDiagonalPrincipal xss) es el producto de los elementos de la diagonal principal de la matriz cuadrada xss. Por ejemplo,

   productoDiagonal1 [[3,5,2],[4,7,1],[6,9,8]]  ==  168
   productoDiagonal1 (replicate 5 [1..5])       ==  120
   length (show (productoDiagonal3 (replicate 30000 [1..30000])))  ==  121288

productoDiagonal1 [[3,5,2],[4,7,1],[6,9,8]] == 168

productoDiagonal1 (replicate 5 [1..5]) == 120

length (show (productoDiagonal3 (replicate 30000 [1..30000]))) == 121288

Soluciones

import Data.List (genericReplicate)

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

productoDiagonal1 :: Num a => [[a]] -> a
productoDiagonal1 xss = product (diagonal1 xss)

-- (diagonal1 xss) es la diagonal de la matriz xss. Por ejemplo,
--    diagonal1 [[3,5,2],[4,7,1],[6,9,0]]  ==  [3,7,0]
--    diagonal1 [[3,5],[4,7],[6,9]]        ==  [3,7]
--    diagonal1 [[3,5,2],[4,7,1]]          ==  [3,7]
diagonal1 :: [[a]] -> [a]
diagonal1 ((x:_):xss) = x : diagonal1 (map tail xss)
diagonal1 _           = []

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

productoDiagonal2 :: Num a => [[a]] -> a
productoDiagonal2 = product . diagonal1

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

productoDiagonal3 :: Num a => [[a]] -> a
productoDiagonal3 = product . diagonal3

diagonal3 :: [[a]] -> [a]
diagonal3 xss = [xs !! k | (xs,k) <- zip xss [0..n]]
  where n = length (head xss) - 1

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

productoDiagonal4 :: Num a => [[a]] -> a
productoDiagonal4 []          = 1
productoDiagonal4 [[]]        = 1
productoDiagonal4 ((x:_):xss) = x * productoDiagonal4 (map tail xss)

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

productoDiagonal5 :: Num a => [[a]] -> a
productoDiagonal5 xss = product (zipWith (!!) xss [0..k])
  where m = length xss
        n = length (head xss)
        k = min m n - 1

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

ejemplo :: Integer -> [[Integer]]
ejemplo n = genericReplicate n [1..n]

-- La comparación es
--    λ> length (show (productoDiagonal1 (ejemplo 7000)))
--    23878
--    (1.23 secs, 3,396,129,424 bytes)
--    λ> length (show (productoDiagonal2 (ejemplo 7000)))
--    23878
--    (0.94 secs, 3,396,127,680 bytes)
--    λ> length (show (productoDiagonal3 (ejemplo 7000)))
--    23878
--    (0.09 secs, 44,841,864 bytes)
--    λ> length (show (productoDiagonal4 (ejemplo 7000)))
--    23878
--    (0.96 secs, 3,614,137,840 bytes)
--    λ> length (show (productoDiagonal5 (ejemplo 7000)))
--    23878
--    (0.07 secs, 44,168,984 bytes)
--
--    λ> length (show (productoDiagonal3 (ejemplo 70000)))
--    308760
--    (8.26 secs, 5,359,752,408 bytes)
--    λ> length (show (productoDiagonal5 (ejemplo 70000)))
--    308760
--    (9.34 secs, 5,353,035,656 bytes)

import Data.List (genericReplicate)

-- 1ª solución

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

productoDiagonal1 :: Num a => [[a]] -> a

productoDiagonal1 xss = product (diagonal1 xss)

-- (diagonal1 xss) es la diagonal de la matriz xss. Por ejemplo,

-- diagonal1 [[3,5,2],[4,7,1],[6,9,0]] == [3,7,0]

-- diagonal1 [[3,5],[4,7],[6,9]] == [3,7]

-- diagonal1 [[3,5,2],[4,7,1]] == [3,7]

diagonal1 :: [[a]] -> [a]

diagonal1 ((x:_):xss) = x : diagonal1 (map tail xss)

diagonal1 _ = []

-- 2ª solución

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

productoDiagonal2 :: Num a => [[a]] -> a

productoDiagonal2 = product . diagonal1

-- 3ª solución

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

productoDiagonal3 :: Num a => [[a]] -> a

productoDiagonal3 = product . diagonal3

diagonal3 :: [[a]] -> [a]

diagonal3 xss = [xs !! k | (xs,k) <- zip xss [0..n]]

where n = length (head xss) - 1

-- 4ª solución

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

productoDiagonal4 :: Num a => [[a]] -> a

productoDiagonal4 [] = 1

productoDiagonal4 [[]] = 1

productoDiagonal4 ((x:_):xss) = x * productoDiagonal4 (map tail xss)

-- 5ª solución

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

productoDiagonal5 :: Num a => [[a]] -> a

productoDiagonal5 xss = product (zipWith (!!) xss [0..k])

where m = length xss

n = length (head xss)

k = min m n - 1

-- Comparación de eficiencia

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

ejemplo :: Integer -> [[Integer]]

ejemplo n = genericReplicate n [1..n]

-- La comparación es

-- λ> length (show (productoDiagonal1 (ejemplo 7000)))

-- 23878

-- (1.23 secs, 3,396,129,424 bytes)

-- λ> length (show (productoDiagonal2 (ejemplo 7000)))

-- 23878

-- (0.94 secs, 3,396,127,680 bytes)

-- λ> length (show (productoDiagonal3 (ejemplo 7000)))

-- 23878

-- (0.09 secs, 44,841,864 bytes)

-- λ> length (show (productoDiagonal4 (ejemplo 7000)))

-- 23878

-- (0.96 secs, 3,614,137,840 bytes)

-- λ> length (show (productoDiagonal5 (ejemplo 7000)))

-- 23878

-- (0.07 secs, 44,168,984 bytes)

-- λ> length (show (productoDiagonal3 (ejemplo 70000)))

-- 308760

-- (8.26 secs, 5,359,752,408 bytes)

-- λ> length (show (productoDiagonal5 (ejemplo 70000)))

-- 308760

-- (9.34 secs, 5,353,035,656 bytes)

El código se encuentra en GitHub.

Reiteración de suma de consecutivos

PorJosé A. Alonso 2-febrero-202223-febrero-2022

La reiteración de la suma de los elementos consecutivos de la lista [1,5,3] es 14 como se explica en el siguiente diagrama

1 + 5 = 6

==> 14

5 + 3 = 8

y la de la lista [1,5,3,4] es 29 como se explica en el siguiente diagrama

   1 + 5 = 6
             \
              ==> 14
             /       \
   5 + 3 = 8          ==> 29
             \       /
              ==> 15
             /
   3 + 4 = 7

1 + 5 = 6

==> 14

/ \

5 + 3 = 8 ==> 29

\ /

==> 15

3 + 4 = 7

Definir la función

   sumaReiterada :: Num a => [a] -> a

1	sumaReiterada :: Num a => [a] -> a

tal que (sumaReiterada xs) es la suma reiterada de los elementos consecutivos de la lista no vacía xs. Por ejemplo,

   sumaReiterada [1,5,3]    ==  14
   sumaReiterada [1,5,3,4]  ==  29

1 2	sumaReiterada [1,5,3] == 14 sumaReiterada [1,5,3,4] == 29

Soluciones

import Test.QuickCheck

import Test.QuickCheck

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

sumaReiterada1 :: Num a => [a] -> a
sumaReiterada1 [x] = x
sumaReiterada1 xs  = sumaReiterada1 [x+y | (x,y) <- consecutivos xs]

-- (consecutivos xs) es la lista de pares de elementos consecutivos de
-- xs. Por ejemplo,
--    consecutivos [1,5,3,4]  ==  [(1,5),(5,3),(3,4)]
consecutivos :: [a] -> [(a,a)]
consecutivos xs = zip xs (tail xs)

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

sumaReiterada2 :: Num a => [a] -> a
sumaReiterada2 [x] = x
sumaReiterada2 xs  = sumaReiterada2 (sumaConsecutivos xs)

-- (sumaConsecutivos xs) es la suma de los de pares de elementos
-- consecutivos de xs. Por ejemplo,
--    sumaConsecutivos [1,5,3,4]   ==  [6,8,7]
sumaConsecutivos :: Num a => [a] -> [a]
sumaConsecutivos xs = zipWith (+) xs (tail xs)

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

sumaReiterada3 :: Num a => [a] -> a
sumaReiterada3 [x] = x
sumaReiterada3 xs  = sumaReiterada3 (zipWith (+) xs (tail xs))

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

sumaReiterada4 :: Num a => [a] -> a
sumaReiterada4 [x]    = x
sumaReiterada4 (x:xs) = sumaReiterada4 (zipWith (+) (x:xs) xs)

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

sumaReiterada5 :: Num a => [a] -> a
sumaReiterada5 [x]       = x
sumaReiterada5 xs@(_:ys) = sumaReiterada5 (zipWith (+) xs ys)

-- 6ª solución
-- ===========

sumaReiterada6 :: Num a => [a] -> a
sumaReiterada6 xs =
  head (head (dropWhile noEsUnitaria (iterate sumaConsecutivos xs)))

-- (noEsUnitaria xs) se verifica si la lista xs no tiene sólo un
-- elemento. Por ejemplo,
--    noEsUnitaria []     ==  True
--    noEsUnitaria [7,5]  ==  True
--    noEsUnitaria [7]    ==  False
noEsUnitaria :: [a] -> Bool
noEsUnitaria [_] = False
noEsUnitaria _   = True

-- 7ª solución
-- ===========

sumaReiterada7 :: Num a => [a] -> a
sumaReiterada7 =
  head . head . dropWhile (not . null . tail) . iterate sumaConsecutivos

-- 8ª solución
-- ===========

sumaReiterada8 :: Num a => [a] -> a
sumaReiterada8 =
  head . head . dropWhile (not . null . tail) . iterate (zipWith (+) =<< tail)

-- 9ª solución
-- ===========

sumaReiterada9 :: Num a => [a] -> a
sumaReiterada9 = head . until ((==1) . length) (zipWith (+) <*> tail)

-- 10ª solución
-- ===========

sumaReiterada10 :: Num a => [a] -> a
sumaReiterada10 xs =
  sum (zipWith (*) xs (map fromIntegral (pascal !! (length xs - 1))))

-- pascal es la lista de las filas del triángulo de Pascal. Por ejemplo,
--    λ> take 7 pascal
--    [[1],[1,1],[1,2,1],[1,3,3,1],[1,4,6,4,1],[1,5,10,10,5,1],[1,6,15,20,15,6,1]]
pascal :: [[Integer]]
pascal = [1] : map f pascal
  where f xs = zipWith (+) (0:xs) (xs++[0])

-- Equivalencia de las definiciones
-- ================================

-- La propiedad es
prop_sumaReiterada :: [Integer] -> Property
prop_sumaReiterada xs =
  not (null xs) ==>
  all (== (sumaReiterada1 xs))
      [f xs | f <- [sumaReiterada2,
                    sumaReiterada3,
                    sumaReiterada4,
                    sumaReiterada5,
                    sumaReiterada6,
                    sumaReiterada7,
                    sumaReiterada8,
                    sumaReiterada9,
                    sumaReiterada10 ]]

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

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

-- La comparación es
--    λ> length (show (sumaReiterada1 [1..4000]))
--    1208
--    (4.84 secs, 4,444,754,000 bytes)
--    λ> length (show (sumaReiterada2 [1..4000]))
--    1208
--    (3.07 secs, 3,332,858,616 bytes)
--    λ> length (show (sumaReiterada3 [1..4000]))
--    1208
--    (3.04 secs, 3,270,112,112 bytes)
--    λ> length (show (sumaReiterada4 [1..4000]))
--    1208
--    (3.05 secs, 3,332,857,768 bytes)
--    λ> length (show (sumaReiterada5 [1..4000]))
--    1208
--    (3.08 secs, 3,332,570,672 bytes)
--    λ> length (show (sumaReiterada6 [1..4000]))
--    1208
--    (3.03 secs, 3,270,469,704 bytes)
--    λ> length (show (sumaReiterada7 [1..4000]))
--    1208
--    (3.03 secs, 3,270,598,416 bytes)
--    λ> length (show (sumaReiterada8 [1..4000]))
--    1208
--    (3.14 secs, 3,202,183,352 bytes)
--    λ> length (show (sumaReiterada9 [1..4000]))
--    1208
--    (3.71 secs, 2,869,137,232 bytes)
--    λ> length (show (sumaReiterada10 [1..4000]))
--    1208
--    (6.48 secs, 4,621,303,752 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

import Test.QuickCheck

-- 1ª solución

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

sumaReiterada1 :: Num a => [a] -> a

sumaReiterada1 [x] = x

sumaReiterada1 xs = sumaReiterada1 [x+y | (x,y) <- consecutivos xs]

-- (consecutivos xs) es la lista de pares de elementos consecutivos de

-- xs. Por ejemplo,

-- consecutivos [1,5,3,4] == [(1,5),(5,3),(3,4)]

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

consecutivos xs = zip xs (tail xs)

-- 2ª solución

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

sumaReiterada2 :: Num a => [a] -> a

sumaReiterada2 [x] = x

sumaReiterada2 xs = sumaReiterada2 (sumaConsecutivos xs)

-- (sumaConsecutivos xs) es la suma de los de pares de elementos

-- consecutivos de xs. Por ejemplo,

-- sumaConsecutivos [1,5,3,4] == [6,8,7]

sumaConsecutivos :: Num a => [a] -> [a]

sumaConsecutivos xs = zipWith (+) xs (tail xs)

-- 3ª solución

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

sumaReiterada3 :: Num a => [a] -> a

sumaReiterada3 [x] = x

sumaReiterada3 xs = sumaReiterada3 (zipWith (+) xs (tail xs))

-- 4ª solución

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

sumaReiterada4 :: Num a => [a] -> a

sumaReiterada4 [x] = x

sumaReiterada4 (x:xs) = sumaReiterada4 (zipWith (+) (x:xs) xs)

-- 5ª solución

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

sumaReiterada5 :: Num a => [a] -> a

sumaReiterada5 [x] = x

sumaReiterada5 xs@(_:ys) = sumaReiterada5 (zipWith (+) xs ys)

-- 6ª solución

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

sumaReiterada6 :: Num a => [a] -> a

sumaReiterada6 xs =

head (head (dropWhile noEsUnitaria (iterate sumaConsecutivos xs)))

-- (noEsUnitaria xs) se verifica si la lista xs no tiene sólo un

-- elemento. Por ejemplo,

-- noEsUnitaria [] == True

-- noEsUnitaria [7,5] == True

-- noEsUnitaria [7] == False

noEsUnitaria :: [a] -> Bool

noEsUnitaria [_] = False

noEsUnitaria _ = True

-- 7ª solución

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

sumaReiterada7 :: Num a => [a] -> a

sumaReiterada7 =

head . head . dropWhile (not . null . tail) . iterate sumaConsecutivos

-- 8ª solución

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

sumaReiterada8 :: Num a => [a] -> a

sumaReiterada8 =

head . head . dropWhile (not . null . tail) . iterate (zipWith (+) =<< tail)

-- 9ª solución

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

sumaReiterada9 :: Num a => [a] -> a

sumaReiterada9 = head . until ((==1) . length) (zipWith (+) <*> tail)

-- 10ª solución

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

sumaReiterada10 :: Num a => [a] -> a

sumaReiterada10 xs =

sum (zipWith (*) xs (map fromIntegral (pascal !! (length xs - 1))))

-- pascal es la lista de las filas del triángulo de Pascal. Por ejemplo,

-- λ> take 7 pascal

-- [[1],[1,1],[1,2,1],[1,3,3,1],[1,4,6,4,1],[1,5,10,10,5,1],[1,6,15,20,15,6,1]]

pascal :: [[Integer]]

pascal = [1] : map f pascal

where f xs = zipWith (+) (0:xs) (xs++[0])

-- Equivalencia de las definiciones

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

-- La propiedad es

prop_sumaReiterada :: [Integer] -> Property

prop_sumaReiterada xs =

not (null xs) ==>

all (== (sumaReiterada1 xs))

[f xs | f <- [sumaReiterada2,

sumaReiterada3,

sumaReiterada4,

sumaReiterada5,

sumaReiterada6,

sumaReiterada7,

sumaReiterada8,

sumaReiterada9,

sumaReiterada10 ]]

-- La comprobación es

-- λ> quickCheck prop_sumaReiterada

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> length (show (sumaReiterada1 [1..4000]))

-- 1208

-- (4.84 secs, 4,444,754,000 bytes)

-- λ> length (show (sumaReiterada2 [1..4000]))

-- 1208

-- (3.07 secs, 3,332,858,616 bytes)

-- λ> length (show (sumaReiterada3 [1..4000]))

-- 1208

-- (3.04 secs, 3,270,112,112 bytes)

-- λ> length (show (sumaReiterada4 [1..4000]))

-- 1208

-- (3.05 secs, 3,332,857,768 bytes)

-- λ> length (show (sumaReiterada5 [1..4000]))

-- 1208

-- (3.08 secs, 3,332,570,672 bytes)

-- λ> length (show (sumaReiterada6 [1..4000]))

-- 1208

-- (3.03 secs, 3,270,469,704 bytes)

-- λ> length (show (sumaReiterada7 [1..4000]))

-- 1208

-- (3.03 secs, 3,270,598,416 bytes)

-- λ> length (show (sumaReiterada8 [1..4000]))

-- 1208

-- (3.14 secs, 3,202,183,352 bytes)

-- λ> length (show (sumaReiterada9 [1..4000]))

-- 1208

-- (3.71 secs, 2,869,137,232 bytes)

-- λ> length (show (sumaReiterada10 [1..4000]))

-- 1208

-- (6.48 secs, 4,621,303,752 bytes)

El código se encuentra en GitHub.

Duplicación de cada elemento

PorJosé A. Alonso 31-enero-202223-febrero-2022

Definir la función

   duplicaElementos :: [a] -> [a]

1	duplicaElementos :: [a] -> [a]

tal que (duplicaElementos xs) es la lista obtenida duplicando cada elemento de xs. Por ejemplo,

   duplicaElementos1 [3,2,5]    ==  [3,3,2,2,5,5]
   duplicaElementos1 "Haskell"  ==  "HHaasskkeellll"

1 2	duplicaElementos1 [3,2,5] == [3,3,2,2,5,5] duplicaElementos1 "Haskell" == "HHaasskkeellll"

Soluciones

import Test.QuickCheck

--  1ª solución
duplicaElementos1 :: [a] -> [a]
duplicaElementos1 [] = []
duplicaElementos1 (x:xs) = x : x : duplicaElementos1 xs

-- 2 solución
duplicaElementos2 :: [a] -> [a]
duplicaElementos2 = foldr (\x ys -> x:x:ys) []

-- 3ª solución
duplicaElementos3 :: [a] -> [a]
duplicaElementos3 xs = concat [[x,x] | x <- xs]

-- 4ª solución
duplicaElementos4 :: [a] -> [a]
duplicaElementos4 xs = concat (map (replicate 2) xs)

-- 5ª solución
duplicaElementos5 :: [a] -> [a]
duplicaElementos5 = concatMap (replicate 2)

-- 6ª solución
duplicaElementos6 :: [a] -> [a]
duplicaElementos6 = (>>= replicate 2)

-- Equivalencia de las definiciones
-- ================================

-- La propiedad es
prop_duplicaElementos :: [Int] -> Bool
prop_duplicaElementos xs =
  all (== (duplicaElementos1 xs))
      [f xs | f <- [duplicaElementos2,
                    duplicaElementos3,
                    duplicaElementos4,
                    duplicaElementos5,
                    duplicaElementos6]]

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

import Test.QuickCheck

-- 1ª solución

duplicaElementos1 :: [a] -> [a]

duplicaElementos1 [] = []

duplicaElementos1 (x:xs) = x : x : duplicaElementos1 xs

-- 2 solución

duplicaElementos2 :: [a] -> [a]

duplicaElementos2 = foldr (\x ys -> x:x:ys) []

-- 3ª solución

duplicaElementos3 :: [a] -> [a]

duplicaElementos3 xs = concat [[x,x] | x <- xs]

-- 4ª solución

duplicaElementos4 :: [a] -> [a]

duplicaElementos4 xs = concat (map (replicate 2) xs)

-- 5ª solución

duplicaElementos5 :: [a] -> [a]

duplicaElementos5 = concatMap (replicate 2)

-- 6ª solución

duplicaElementos6 :: [a] -> [a]

duplicaElementos6 = (>>= replicate 2)

-- Equivalencia de las definiciones

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

-- La propiedad es

prop_duplicaElementos :: [Int] -> Bool

prop_duplicaElementos xs =

all (== (duplicaElementos1 xs))

[f xs | f <- [duplicaElementos2,

duplicaElementos3,

duplicaElementos4,

duplicaElementos5,

duplicaElementos6]]

-- La comprobación es

-- λ> quickCheck prop_duplicaElementos

-- +++ OK, passed 100 tests.

El código se encuentra en GitHub.

Sistema factorádico de numeración

PorJosé A. Alonso 28-enero-202215-abril-2022

El sistema factorádico es un sistema numérico basado en factoriales en el que el n-ésimo dígito, empezando desde la derecha, debe ser multiplicado por n! Por ejemplo, el número «341010» en el sistema factorádico es 463 en el sistema decimal ya que

   3×5! + 4×4! + 1×3! + 0×2! + 1×1! + 0×0! = 463

1	3×5! + 4×4! + 1×3! + 0×2! + 1×1! + 0×0! = 463

En este sistema numérico, el dígito de más a la derecha es siempre 0, el segundo 0 o 1, el tercero 0,1 o 2 y así sucesivamente.

Con los dígitos del 0 al 9 el mayor número que podemos codificar es el 10!-1 = 3628799. En cambio, si lo ampliamos con las letras A a Z podemos codificar hasta 36!-1 = 37199332678990121746799944815083519999999910.

Definir las funciones

   factoradicoAdecimal :: String -> Integer
   decimalAfactoradico :: Integer -> String

1 2	factoradicoAdecimal :: String -> Integer decimalAfactoradico :: Integer -> String

tales que

(factoradicoAdecimal cs) es el número decimal correspondiente al número factorádico cs. Por ejemplo,

     λ> decimalAfactoradico 463
     "341010"
     λ> decimalAfactoradico 2022
     "2441000"
     λ> decimalAfactoradico 36288000
     "A0000000000"
     λ> map decimalAfactoradico [1..10]
     ["10","100","110","200","210","1000","1010","1100","1110","1200"]
     λ> decimalAfactoradico 37199332678990121746799944815083519999999
     "3KXWVUTSRQPONMLKJIHGFEDCBA9876543210"

λ> decimalAfactoradico 463

"341010"

λ> decimalAfactoradico 2022

"2441000"

λ> decimalAfactoradico 36288000

"A0000000000"

λ> map decimalAfactoradico [1..10]

["10","100","110","200","210","1000","1010","1100","1110","1200"]

λ> decimalAfactoradico 37199332678990121746799944815083519999999

"3KXWVUTSRQPONMLKJIHGFEDCBA9876543210"

(decimalAfactoradico n) es el número factorádico correpondiente al número decimal n. Por ejemplo,

     λ> factoradicoAdecimal "341010"
     463
     λ> factoradicoAdecimal "2441000"
     2022
     λ> factoradicoAdecimal "A0000000000"
     36288000
     λ> map factoradicoAdecimal ["10","100","110","200","210","1000","1010","1100","1110","1200"]
     [1,2,3,4,5,6,7,8,9,10]
     λ> factoradicoAdecimal "3KXWVUTSRQPONMLKJIHGFEDCBA9876543210"
     37199332678990121746799944815083519999999

λ> factoradicoAdecimal "341010"

463

λ> factoradicoAdecimal "2441000"

2022

λ> factoradicoAdecimal "A0000000000"

36288000

λ> map factoradicoAdecimal ["10","100","110","200","210","1000","1010","1100","1110","1200"]

[1,2,3,4,5,6,7,8,9,10]

λ> factoradicoAdecimal "3KXWVUTSRQPONMLKJIHGFEDCBA9876543210"

37199332678990121746799944815083519999999

Comprobar con QuickCheck que, para cualquier entero positivo n,

   factoradicoAdecimal (decimalAfactoradico n) == n

1	factoradicoAdecimal (decimalAfactoradico n) == n

Soluciones

{-# LANGUAGE TupleSections #-}

import Data.List (genericIndex, genericLength)
import qualified Data.Map as M
import Test.QuickCheck
import Test.Hspec

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

factoradicoAdecimal1 :: String -> Integer
factoradicoAdecimal1 cs = sum (zipWith (*) xs ys)
  where xs = map caracterAentero cs
        n  = length cs
        ys = reverse (take n facts)

-- (caracterAentero c) es la posición del carácter c en la lista de
-- caracteres ['0', '1',..., '9', 'A', 'B',..., 'Z']. Por ejemplo,
--    caracterAentero '0'  ==  0
--    caracterAentero '1'  ==  1
--    caracterAentero '9'  ==  9
--    caracterAentero 'A'  ==  10
--    caracterAentero 'B'  ==  11
--    caracterAentero 'Z'  ==  35
caracterAentero :: Char -> Integer
caracterAentero c =
  head [n | (n,x) <- zip [0..] caracteres, x == c]

-- caracteres es la lista de caracteres
-- ['0', '1',..., '9', 'A', 'B',..., 'Z']
caracteres :: String
caracteres = ['0'..'9'] ++ ['A'..'Z']

-- facts es la lista de los factoriales. Por ejemplo,
--    λ> take 12 facts
--    [1,1,2,6,24,120,720,5040,40320,362880,3628800,39916800]
facts :: [Integer]
facts = scanl (*) 1 [1..]

decimalAfactoradico1 :: Integer -> String
decimalAfactoradico1 n = aux n (reverse (takeWhile (<=n) facts))
  where aux 0 xs     = ['0' | _ <- xs]
        aux m (x:xs) = enteroAcaracter (m `div` x) : aux (m `mod` x) xs

-- (enteroAcaracter k) es el k-ésimo elemento de la lista
-- ['0', '1',..., '9', 'A', 'B',..., 'Z']. . Por ejemplo,
--    enteroAcaracter 0   ==  '0'
--    enteroAcaracter 1   ==  '1'
--    enteroAcaracter 9   ==  '9'
--    enteroAcaracter 10  ==  'A'
--    enteroAcaracter 11  ==  'B'
--    enteroAcaracter 35  ==  'Z'
enteroAcaracter :: Integer -> Char
enteroAcaracter k = caracteres `genericIndex` k

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

factoradicoAdecimal2 :: String -> Integer
factoradicoAdecimal2 cs = sum (zipWith (*) xs ys)
    where xs = map caracterAentero2 cs
          n  = length cs
          ys = reverse (take n facts)

-- (caracterAentero2 c) es la posición del carácter c en la lista de
-- caracteres ['0', '1',..., '9', 'A', 'B',..., 'Z']. Por ejemplo,
--    caracterAentero2 '0'  ==  0
--    caracterAentero2 '1'  ==  1
--    caracterAentero2 '9'  ==  9
--    caracterAentero2 'A'  ==  10
--    caracterAentero2 'B'  ==  11
--    caracterAentero2 'Z'  ==  35
caracterAentero2 :: Char -> Integer
caracterAentero2 c = caracteresEnteros M.! c

-- caracteresEnteros es el diccionario cuyas claves son los caracteres y
-- las claves son los números de 0 a 35.
caracteresEnteros :: M.Map Char Integer
caracteresEnteros = M.fromList (zip (['0'..'9'] ++ ['A'..'Z']) [0..])

decimalAfactoradico2 :: Integer -> String
decimalAfactoradico2 n = aux n (reverse (takeWhile (<=n) facts))
    where aux 0 xs     = ['0' | _ <- xs]
          aux m (x:xs) = enteroAcaracter2 (m `div` x) : aux (m `mod` x) xs

-- (enteroAcaracter2 k) es el k-ésimo elemento de la lista
-- ['0', '1',..., '9', 'A', 'B',..., 'Z']. . Por ejemplo,
--    enteroAcaracter2 0   ==  '0'
--    enteroAcaracter2 1   ==  '1'
--    enteroAcaracter2 9   ==  '9'
--    enteroAcaracter2 10  ==  'A'
--    enteroAcaracter2 11  ==  'B'
--    enteroAcaracter2 35  ==  'Z'
enteroAcaracter2 :: Integer -> Char
enteroAcaracter2 k = enterosCaracteres M.! k

-- enterosCaracteres es el diccionario cuyas claves son los número de 0
-- a 35 y las claves son los caracteres.
enterosCaracteres :: M.Map Integer Char
enterosCaracteres = M.fromList (zip [0..] caracteres)

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

factoradicoAdecimal3 :: String -> Integer
factoradicoAdecimal3 cs =
  sum (zipWith (*) facts (reverse (map caracterAentero3 cs)))

-- (caracterAentero3 c) es la posición del carácter c en la lista de
-- caracteres ['0', '1',..., '9', 'A', 'B',..., 'Z']. Por ejemplo,
--    caracterAentero3 '0'  ==  0
--    caracterAentero3 '1'  ==  1
--    caracterAentero3 '9'  ==  9
--    caracterAentero3 'A'  ==  10
--    caracterAentero3 'B'  ==  11
--    caracterAentero3 'Z'  ==  35
caracterAentero3 :: Char -> Integer
caracterAentero3 c =
  genericLength (takeWhile (/= c) caracteres)

decimalAfactoradico3 :: Integer -> String
decimalAfactoradico3 n = aux "" 2 (n, 0)
  where aux s _ (0, 0) = s
        aux s n (d, r) = aux (enteroAcaracter3 r: s) (n + 1) (d `divMod` n)

-- (enteroAcaracter3 k) es el k-ésimo elemento de la lista
-- ['0', '1',..., '9', 'A', 'B',..., 'Z']. . Por ejemplo,
--    enteroAcaracter3 0   ==  '0'
--    enteroAcaracter3 1   ==  '1'
--    enteroAcaracter3 9   ==  '9'
--    enteroAcaracter3 10  ==  'A'
--    enteroAcaracter3 11  ==  'B'
--    enteroAcaracter3 35  ==  'Z'
enteroAcaracter3 :: Integer -> Char
enteroAcaracter3 n =
  caracteres !! (fromInteger n)

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

factoradicoAdecimal4 :: String -> Integer
factoradicoAdecimal4 =
  sum . zipWith (*) facts . reverse . map caracterAentero4

-- (caracterAentero4 c) es la posición del carácter c en la lista de
-- caracteres ['0', '1',..., '9', 'A', 'B',..., 'Z']. Por ejemplo,
--    caracterAentero4 '0'  ==  0
--    caracterAentero4 '1'  ==  1
--    caracterAentero4 '9'  ==  9
--    caracterAentero4 'A'  ==  10
--    caracterAentero4 'B'  ==  11
--    caracterAentero4 'Z'  ==  35
caracterAentero4 :: Char -> Integer
caracterAentero4 =
  genericLength . flip takeWhile caracteres . (/=)

decimalAfactoradico4 :: Integer -> String
decimalAfactoradico4 = f "" 2 . (, 0)
  where f s _ (0, 0) = s
        f s n (d, r) = f (enteroAcaracter4 r: s) (n + 1) (d `divMod` n)

-- (enteroAcaracter4 k) es el k-ésimo elemento de la lista
-- ['0', '1',..., '9', 'A', 'B',..., 'Z']. . Por ejemplo,
--    enteroAcaracter4 0   ==  '0'
--    enteroAcaracter4 1   ==  '1'
--    enteroAcaracter4 9   ==  '9'
--    enteroAcaracter4 10  ==  'A'
--    enteroAcaracter4 11  ==  'B'
--    enteroAcaracter4 35  ==  'Z'
enteroAcaracter4 :: Integer -> Char
enteroAcaracter4 = (caracteres `genericIndex`)

-- Propiedad de inverso
-- ====================

prop_factoradico :: Integer -> Property
prop_factoradico n =
  n >= 0 ==>
  factoradicoAdecimal1 (decimalAfactoradico1 n) == n &&
  factoradicoAdecimal2 (decimalAfactoradico2 n) == n &&
  factoradicoAdecimal3 (decimalAfactoradico3 n) == n &&
  factoradicoAdecimal4 (decimalAfactoradico4 n) == n

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

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

-- La comparación es
--    λ> length (decimalAfactoradico1 (10^300000))
--    68191
--    (2.46 secs, 9,088,634,744 bytes)
--    λ> length (decimalAfactoradico2 (10^300000))
--    68191
--    (2.36 secs, 9,088,634,800 bytes)
--    λ> length (decimalAfactoradico3 (10^300000))
--    68191
--    (2.18 secs, 4,490,856,416 bytes)
--    λ> length (decimalAfactoradico4 (10^300000))
--    68191
--    (1.98 secs, 4,490,311,536 bytes)
--
--    λ> length (show (factoradicoAdecimal1 (show (10^50000))))
--    213237
--    (0.93 secs, 2,654,156,680 bytes)
--    λ> length (show (factoradicoAdecimal2 (show (10^50000))))
--    213237
--    (0.51 secs, 2,633,367,168 bytes)
--    λ> length (show (factoradicoAdecimal3 (show (10^50000))))
--    213237
--    (0.93 secs, 2,635,792,192 bytes)
--    λ> length (show (factoradicoAdecimal4 (show (10^50000))))
--    213237
--    (0.43 secs, 2,636,996,848 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

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

{-# LANGUAGE TupleSections #-}

import Data.List (genericIndex, genericLength)

import qualified Data.Map as M

import Test.QuickCheck

import Test.Hspec

-- 1ª solución

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

factoradicoAdecimal1 :: String -> Integer

factoradicoAdecimal1 cs = sum (zipWith (*) xs ys)

where xs = map caracterAentero cs

n = length cs

ys = reverse (take n facts)

-- (caracterAentero c) es la posición del carácter c en la lista de

-- caracteres ['0', '1',..., '9', 'A', 'B',..., 'Z']. Por ejemplo,

-- caracterAentero '0' == 0

-- caracterAentero '1' == 1

-- caracterAentero '9' == 9

-- caracterAentero 'A' == 10

-- caracterAentero 'B' == 11

-- caracterAentero 'Z' == 35

caracterAentero :: Char -> Integer

caracterAentero c =

head [n | (n,x) <- zip [0..] caracteres, x == c]

-- caracteres es la lista de caracteres

-- ['0', '1',..., '9', 'A', 'B',..., 'Z']

caracteres :: String

caracteres = ['0'..'9'] ++ ['A'..'Z']

-- facts es la lista de los factoriales. Por ejemplo,

-- λ> take 12 facts

-- [1,1,2,6,24,120,720,5040,40320,362880,3628800,39916800]

facts :: [Integer]

facts = scanl (*) 1 [1..]

decimalAfactoradico1 :: Integer -> String

decimalAfactoradico1 n = aux n (reverse (takeWhile (<=n) facts))

where aux 0 xs = ['0' | _ <- xs]

aux m (x:xs) = enteroAcaracter (m `div` x) : aux (m `mod` x) xs

-- (enteroAcaracter k) es el k-ésimo elemento de la lista

-- ['0', '1',..., '9', 'A', 'B',..., 'Z']. . Por ejemplo,

-- enteroAcaracter 0 == '0'

-- enteroAcaracter 1 == '1'

-- enteroAcaracter 9 == '9'

-- enteroAcaracter 10 == 'A'

-- enteroAcaracter 11 == 'B'

-- enteroAcaracter 35 == 'Z'

enteroAcaracter :: Integer -> Char

enteroAcaracter k = caracteres `genericIndex` k

-- 2ª solución

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

factoradicoAdecimal2 :: String -> Integer

factoradicoAdecimal2 cs = sum (zipWith (*) xs ys)

where xs = map caracterAentero2 cs

n = length cs

ys = reverse (take n facts)

-- (caracterAentero2 c) es la posición del carácter c en la lista de

-- caracteres ['0', '1',..., '9', 'A', 'B',..., 'Z']. Por ejemplo,

-- caracterAentero2 '0' == 0

-- caracterAentero2 '1' == 1

-- caracterAentero2 '9' == 9

-- caracterAentero2 'A' == 10

-- caracterAentero2 'B' == 11

-- caracterAentero2 'Z' == 35

caracterAentero2 :: Char -> Integer

caracterAentero2 c = caracteresEnteros M.! c

-- caracteresEnteros es el diccionario cuyas claves son los caracteres y

-- las claves son los números de 0 a 35.

caracteresEnteros :: M.Map Char Integer

caracteresEnteros = M.fromList (zip (['0'..'9'] ++ ['A'..'Z']) [0..])

decimalAfactoradico2 :: Integer -> String

decimalAfactoradico2 n = aux n (reverse (takeWhile (<=n) facts))

where aux 0 xs = ['0' | _ <- xs]

aux m (x:xs) = enteroAcaracter2 (m `div` x) : aux (m `mod` x) xs

-- (enteroAcaracter2 k) es el k-ésimo elemento de la lista

-- ['0', '1',..., '9', 'A', 'B',..., 'Z']. . Por ejemplo,

-- enteroAcaracter2 0 == '0'

-- enteroAcaracter2 1 == '1'

-- enteroAcaracter2 9 == '9'

-- enteroAcaracter2 10 == 'A'

-- enteroAcaracter2 11 == 'B'

-- enteroAcaracter2 35 == 'Z'

enteroAcaracter2 :: Integer -> Char

enteroAcaracter2 k = enterosCaracteres M.! k

-- enterosCaracteres es el diccionario cuyas claves son los número de 0

-- a 35 y las claves son los caracteres.

enterosCaracteres :: M.Map Integer Char

enterosCaracteres = M.fromList (zip [0..] caracteres)

-- 3ª solución

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

factoradicoAdecimal3 :: String -> Integer

factoradicoAdecimal3 cs =

sum (zipWith (*) facts (reverse (map caracterAentero3 cs)))

-- (caracterAentero3 c) es la posición del carácter c en la lista de

-- caracteres ['0', '1',..., '9', 'A', 'B',..., 'Z']. Por ejemplo,

-- caracterAentero3 '0' == 0

-- caracterAentero3 '1' == 1

-- caracterAentero3 '9' == 9

-- caracterAentero3 'A' == 10

-- caracterAentero3 'B' == 11

-- caracterAentero3 'Z' == 35

caracterAentero3 :: Char -> Integer

caracterAentero3 c =

genericLength (takeWhile (/= c) caracteres)

decimalAfactoradico3 :: Integer -> String

decimalAfactoradico3 n = aux "" 2 (n, 0)

where aux s _ (0, 0) = s

aux s n (d, r) = aux (enteroAcaracter3 r: s) (n + 1) (d `divMod` n)

-- (enteroAcaracter3 k) es el k-ésimo elemento de la lista

-- ['0', '1',..., '9', 'A', 'B',..., 'Z']. . Por ejemplo,

-- enteroAcaracter3 0 == '0'

-- enteroAcaracter3 1 == '1'

-- enteroAcaracter3 9 == '9'

-- enteroAcaracter3 10 == 'A'

-- enteroAcaracter3 11 == 'B'

-- enteroAcaracter3 35 == 'Z'

enteroAcaracter3 :: Integer -> Char

enteroAcaracter3 n =

caracteres !! (fromInteger n)

-- 4ª solución

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

factoradicoAdecimal4 :: String -> Integer

factoradicoAdecimal4 =

sum . zipWith (*) facts . reverse . map caracterAentero4

-- (caracterAentero4 c) es la posición del carácter c en la lista de

-- caracteres ['0', '1',..., '9', 'A', 'B',..., 'Z']. Por ejemplo,

-- caracterAentero4 '0' == 0

-- caracterAentero4 '1' == 1

-- caracterAentero4 '9' == 9

-- caracterAentero4 'A' == 10

-- caracterAentero4 'B' == 11

-- caracterAentero4 'Z' == 35

caracterAentero4 :: Char -> Integer

caracterAentero4 =

genericLength . flip takeWhile caracteres . (/=)

decimalAfactoradico4 :: Integer -> String

decimalAfactoradico4 = f "" 2 . (, 0)

where f s _ (0, 0) = s

f s n (d, r) = f (enteroAcaracter4 r: s) (n + 1) (d `divMod` n)

-- (enteroAcaracter4 k) es el k-ésimo elemento de la lista

-- ['0', '1',..., '9', 'A', 'B',..., 'Z']. . Por ejemplo,

-- enteroAcaracter4 0 == '0'

-- enteroAcaracter4 1 == '1'

-- enteroAcaracter4 9 == '9'

-- enteroAcaracter4 10 == 'A'

-- enteroAcaracter4 11 == 'B'

-- enteroAcaracter4 35 == 'Z'

enteroAcaracter4 :: Integer -> Char

enteroAcaracter4 = (caracteres `genericIndex`)

-- Propiedad de inverso

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

prop_factoradico :: Integer -> Property

prop_factoradico n =

n >= 0 ==>

factoradicoAdecimal1 (decimalAfactoradico1 n) == n &&

factoradicoAdecimal2 (decimalAfactoradico2 n) == n &&

factoradicoAdecimal3 (decimalAfactoradico3 n) == n &&

factoradicoAdecimal4 (decimalAfactoradico4 n) == n

-- La comprobación es

-- λ> quickCheck prop_factoradico

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> length (decimalAfactoradico1 (10^300000))

-- 68191

-- (2.46 secs, 9,088,634,744 bytes)

-- λ> length (decimalAfactoradico2 (10^300000))

-- 68191

-- (2.36 secs, 9,088,634,800 bytes)

-- λ> length (decimalAfactoradico3 (10^300000))

-- 68191

-- (2.18 secs, 4,490,856,416 bytes)

-- λ> length (decimalAfactoradico4 (10^300000))

-- 68191

-- (1.98 secs, 4,490,311,536 bytes)

-- λ> length (show (factoradicoAdecimal1 (show (10^50000))))

-- 213237

-- (0.93 secs, 2,654,156,680 bytes)

-- λ> length (show (factoradicoAdecimal2 (show (10^50000))))

-- 213237

-- (0.51 secs, 2,633,367,168 bytes)

-- λ> length (show (factoradicoAdecimal3 (show (10^50000))))

-- 213237

-- (0.93 secs, 2,635,792,192 bytes)

-- λ> length (show (factoradicoAdecimal4 (show (10^50000))))

-- 213237

-- (0.43 secs, 2,636,996,848 bytes)

El código se encuentra en GitHub.

Cuadrado más cercano

PorJosé A. Alonso 26-enero-202216-marzo-2022

Definir la función

   cuadradoCercano :: Integer -> Integer

1	cuadradoCercano :: Integer -> Integer

tal que (cuadradoCercano n) es el número cuadrado más cercano a n, donde n es un entero positivo. Por ejemplo,

   cuadradoCercano 2       == 1
   cuadradoCercano 6       == 4
   cuadradoCercano 8       == 9
   cuadradoCercano (10^46) == 10000000000000000000000000000000000000000000000

cuadradoCercano 2 == 1

cuadradoCercano 6 == 4

cuadradoCercano 8 == 9

cuadradoCercano (10^46) == 10000000000000000000000000000000000000000000000

Soluciones

import Test.QuickCheck

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

cuadradoCercano1 :: Integer -> Integer
cuadradoCercano1 n
  | n - b < c - n = b
  | otherwise     = c
  where a = raizEntera1 n
        b = a^2
        c = (a+1)^2

-- (raizEntera x) es el mayor entero cuyo cuadrado no es mayor que
-- x. Por ejemplo,
--    raizEntera 8   ==  2
--    raizEntera 9   ==  3
--    raizEntera 10  ==  3
raizEntera1 :: Integer -> Integer
raizEntera1 x =
  last (takeWhile (\n -> n^2 <= x) [1..])

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

cuadradoCercano2 :: Integer -> Integer
cuadradoCercano2 n
  | n - b < c - n = b
  | otherwise     = c
  where a = raizEntera2 n
        b = a^2
        c = (a+1)^2

raizEntera2 :: Integer -> Integer
raizEntera2 x = aux (1,x)
    where aux (a,b) | d == x    = c
                    | c == a    = c
                    | x <= d    = aux (a,c)
                    | otherwise = aux (c,b)
            where c = (a+b) `div` 2
                  d = c^2

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

cuadradoCercano3 :: Integer -> Integer
cuadradoCercano3 n
  | n - b < c - n = b
  | otherwise     = c
  where a = raizEntera3 n
        b = a^2
        c = (a+1)^2

raizEntera3 :: Integer -> Integer
raizEntera3 0 = 0
raizEntera3 1 = 1
raizEntera3 n = until aceptable mejora n
  where mejora x    = (x + n `div` x) `div` 2
        aceptable x = x^2 <= n

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

cuadradoCercano4 :: Integer -> Integer
cuadradoCercano4 = (^ 2) . round . sqrt . fromIntegral

-- Equivalencia de las definiciones
-- ================================

-- La propiedad es
prop_cuadradoCercano :: Positive Integer -> Bool
prop_cuadradoCercano (Positive x) =
  all (== cuadradoCercano1 x)
      [cuadradoCercano2 x,
       cuadradoCercano3 x,
       cuadradoCercano4 x]

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

-- Aunque ha pasado los 100 tests, las definiciones no son
-- equivalentes. Por ejemplo,
--    λ> cuadradoCercano3 (10^46) == cuadradoCercano (10^46)
--    False
--    λ> cuadradoCercano3 (10^46)
--    9999999999999998322278400000000070368744177664
--    λ> cuadradoCercano (10^46)
--    10000000000000000000000000000000000000000000000

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

-- La comparación es
--    λ> cuadradoCercano1 (10^14)
--    100000000000000
--    (4.59 secs, 5,920,475,784 bytes)
--    λ> cuadradoCercano2 (10^14)
--    100000000000000
--    (0.01 secs, 512,472 bytes)
--    λ> cuadradoCercano3 (10^14)
--    100000000000000
--    (0.01 secs, 494,248 bytes)
--    λ> cuadradoCercano4 (10^14)
--    100000000000000
--    (0.01 secs, 475,152 bytes)
--
--    λ> length (show (cuadradoCercano2 (10^20000)))
--    20001
--    (3.94 secs, 1,446,675,504 bytes)
--    λ> length (show (cuadradoCercano3 (10^20000)))
--    20001
--    (4.50 secs, 926,647,904 bytes)

100

101

102

103

104

105

106

107

108

109

110

111

112

113

import Test.QuickCheck

-- 1ª solución

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

cuadradoCercano1 :: Integer -> Integer

cuadradoCercano1 n

| n - b < c - n = b

| otherwise = c

where a = raizEntera1 n

b = a^2

c = (a+1)^2

-- (raizEntera x) es el mayor entero cuyo cuadrado no es mayor que

-- x. Por ejemplo,

-- raizEntera 8 == 2

-- raizEntera 9 == 3

-- raizEntera 10 == 3

raizEntera1 :: Integer -> Integer

raizEntera1 x =

last (takeWhile (\n -> n^2 <= x) [1..])

-- 2ª solución

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

cuadradoCercano2 :: Integer -> Integer

cuadradoCercano2 n

| n - b < c - n = b

| otherwise = c

where a = raizEntera2 n

b = a^2

c = (a+1)^2

raizEntera2 :: Integer -> Integer

raizEntera2 x = aux (1,x)

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

| c == a = c

| x <= d = aux (a,c)

| otherwise = aux (c,b)

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

d = c^2

-- 3ª solución

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

cuadradoCercano3 :: Integer -> Integer

cuadradoCercano3 n

| n - b < c - n = b

| otherwise = c

where a = raizEntera3 n

b = a^2

c = (a+1)^2

raizEntera3 :: Integer -> Integer

raizEntera3 0 = 0

raizEntera3 1 = 1

raizEntera3 n = until aceptable mejora n

where mejora x = (x + n `div` x) `div` 2

aceptable x = x^2 <= n

-- 4ª solución

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

cuadradoCercano4 :: Integer -> Integer

cuadradoCercano4 = (^ 2) . round . sqrt . fromIntegral

-- Equivalencia de las definiciones

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

-- La propiedad es

prop_cuadradoCercano :: Positive Integer -> Bool

prop_cuadradoCercano (Positive x) =

all (== cuadradoCercano1 x)

[cuadradoCercano2 x,

cuadradoCercano3 x,

cuadradoCercano4 x]

-- La comprobación es

-- λ> quickCheck prop_cuadradoCercano

-- +++ OK, passed 100 tests.

-- Aunque ha pasado los 100 tests, las definiciones no son

-- equivalentes. Por ejemplo,

-- λ> cuadradoCercano3 (10^46) == cuadradoCercano (10^46)

-- False

-- λ> cuadradoCercano3 (10^46)

-- 9999999999999998322278400000000070368744177664

-- λ> cuadradoCercano (10^46)

-- 10000000000000000000000000000000000000000000000

-- Comparación de eficiencia

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

-- La comparación es

-- λ> cuadradoCercano1 (10^14)

-- 100000000000000

-- (4.59 secs, 5,920,475,784 bytes)

-- λ> cuadradoCercano2 (10^14)

-- 100000000000000

-- (0.01 secs, 512,472 bytes)

-- λ> cuadradoCercano3 (10^14)

-- 100000000000000

-- (0.01 secs, 494,248 bytes)

-- λ> cuadradoCercano4 (10^14)

-- 100000000000000

-- (0.01 secs, 475,152 bytes)

-- λ> length (show (cuadradoCercano2 (10^20000)))

-- 20001

-- (3.94 secs, 1,446,675,504 bytes)

-- λ> length (show (cuadradoCercano3 (10^20000)))

-- 20001

-- (4.50 secs, 926,647,904 bytes)

El código se encuentra en GitHub

La elaboración de las soluciones se muestra en el siguiente vídeo:

Caminos reducidos

PorJosé A. Alonso 5-junio-20202-enero-2021

Un camino es una sucesión de pasos en una de las cuatros direcciones Norte, Sur, Este, Oeste. Ir en una dirección y a continuación en la opuesta es un esfuerzo que se puede reducir, Por ejemplo, el camino [Norte,Sur,Este,Sur] se puede reducir a [Este,Sur].

Un camino se dice que es reducido si no tiene dos pasos consecutivos en direcciones opuesta. Por ejemplo, [Este,Sur] es reducido y [Norte,Sur,Este,Sur] no lo es.

En Haskell, las direcciones y los caminos se pueden definir por

   data Direccion = N | S | E | O deriving (Show, Eq)
   type Camino = [Direccion]

1 2	data Direccion = N \| S \| E \| O deriving (Show, Eq) type Camino = [Direccion]

Definir la función

   reducido :: Camino -> Camino

1	reducido :: Camino -> Camino

tal que (reducido ds) es el camino reducido equivalente al camino ds. Por ejemplo,

   reducido []                              ==  []
   reducido [N]                             ==  [N]
   reducido [N,O]                           ==  [N,O]
   reducido [N,O,E]                         ==  [N]
   reducido [N,O,E,S]                       ==  [] 
   reducido [N,O,S,E]                       ==  [N,O,S,E]
   reducido [S,S,S,N,N,N]                   ==  []
   reducido [N,S,S,E,O,N]                   ==  []
   reducido [N,S,S,E,O,N,O]                 ==  [O]
   reducido (take (10^7) (cycle [N,E,O,S])) ==  []

reducido [] == []

reducido [N] == [N]

reducido [N,O] == [N,O]

reducido [N,O,E] == [N]

reducido [N,O,E,S] == []

reducido [N,O,S,E] == [N,O,S,E]

reducido [S,S,S,N,N,N] == []

reducido [N,S,S,E,O,N] == []

reducido [N,S,S,E,O,N,O] == [O]

reducido (take (10^7) (cycle [N,E,O,S])) == []

Nótese que en el penúltimo ejemplo las reducciones son

       [N,S,S,E,O,N,O]  
   --> [S,E,O,N,O]  
   --> [S,N,O]  
   --> [O]

[N,S,S,E,O,N,O]

--> [S,E,O,N,O]

--> [S,N,O]

--> [O]

Soluciones

data Direccion = N | S | E | O deriving (Show, Eq)

type Camino = [Direccion]

-- 1ª solución (por recursión):
reducido1 :: Camino -> Camino
reducido1 [] = []
reducido1 (d:ds) | null ds'                = [d]
                 | d == opuesta (head ds') = tail ds'
                 | otherwise               = d:ds'
    where ds' = reducido1 ds

opuesta :: Direccion -> Direccion
opuesta N = S
opuesta S = N
opuesta E = O
opuesta O = E

-- 2ª solución (por plegado)
reducido2 :: Camino -> Camino
reducido2 = foldr aux []
    where aux N (S:xs) = xs
          aux S (N:xs) = xs
          aux E (O:xs) = xs
          aux O (E:xs) = xs
          aux x xs     = x:xs

-- 3ª solución 
reducido3 :: Camino -> Camino
reducido3 []       = []
reducido3 (N:S:ds) = reducido3 ds
reducido3 (S:N:ds) = reducido3 ds
reducido3 (E:O:ds) = reducido3 ds
reducido3 (O:E:ds) = reducido3 ds
reducido3 (d:ds) | null ds'                = [d]
                 | d == opuesta (head ds') = tail ds'
                 | otherwise               = d:ds'
    where ds' = reducido3 ds

-- 4ª solución
reducido4 :: Camino -> Camino
reducido4 ds = reverse (aux ([],ds)) where 
    aux (N:xs, S:ys) = aux (xs,ys)
    aux (S:xs, N:ys) = aux (xs,ys)
    aux (E:xs, O:ys) = aux (xs,ys)
    aux (O:xs, E:ys) = aux (xs,ys)
    aux (  xs, y:ys) = aux (y:xs,ys)
    aux (  xs,   []) = xs

-- Comparación de eficiencia
--    ghci> reducido1 (take (10^6) (cycle [N,E,O,S]))
--    []
--    (3.87 secs, 460160736 bytes)
--    ghci> reducido2 (take (10^6) (cycle [N,E,O,S]))
--    []
--    (1.16 secs, 216582880 bytes)
--    ghci> reducido3 (take (10^6) (cycle [N,E,O,S]))
--    []
--    (0.58 secs, 98561872 bytes)
--    ghci> reducido4 (take (10^6) (cycle [N,E,O,S]))
--    []
--    (0.64 secs, 176154640 bytes)
--    
--    ghci> reducido3 (take (10^7) (cycle [N,E,O,S]))
--    []
--    (5.43 secs, 962694784 bytes)
--    ghci> reducido4 (take (10^7) (cycle [N,E,O,S]))
--    []
--    (9.29 secs, 1722601528 bytes)
-- 
--    ghci> length $ reducido3 (take 2000000 $ cycle [N,O,N,S,E,N,S,O,S,S])
--    400002
--    (4.52 secs, 547004960 bytes)
--    ghci> length $ reducido4 (take 2000000 $ cycle [N,O,N,S,E,N,S,O,S,S])
--    400002
--    
--    ghci> let n=10^6 in reducido1 (replicate n N ++ replicate n S)
--    []
--    (7.35 secs, 537797096 bytes)
--    ghci> let n=10^6 in reducido2 (replicate n N ++ replicate n S)
--    []
--    (2.30 secs, 244553404 bytes)
--    ghci> let n=10^6 in reducido3 (replicate n N ++ replicate n S)
--    []
--    (8.08 secs, 545043608 bytes)
--    ghci> let n=10^6 in reducido4 (replicate n N ++ replicate n S)
--    []
--    (1.96 secs, 205552240 bytes)

data Direccion = N | S | E | O deriving (Show, Eq)

type Camino = [Direccion]

-- 1ª solución (por recursión):

reducido1 :: Camino -> Camino

reducido1 [] = []

reducido1 (d:ds) | null ds' = [d]

| d == opuesta (head ds') = tail ds'

| otherwise = d:ds'

where ds' = reducido1 ds

opuesta :: Direccion -> Direccion

opuesta N = S

opuesta S = N

opuesta E = O

opuesta O = E

-- 2ª solución (por plegado)

reducido2 :: Camino -> Camino

reducido2 = foldr aux []

where aux N (S:xs) = xs

aux S (N:xs) = xs

aux E (O:xs) = xs

aux O (E:xs) = xs

aux x xs = x:xs

-- 3ª solución

reducido3 :: Camino -> Camino

reducido3 [] = []

reducido3 (N:S:ds) = reducido3 ds

reducido3 (S:N:ds) = reducido3 ds

reducido3 (E:O:ds) = reducido3 ds

reducido3 (O:E:ds) = reducido3 ds

reducido3 (d:ds) | null ds' = [d]

| d == opuesta (head ds') = tail ds'

| otherwise = d:ds'

where ds' = reducido3 ds

-- 4ª solución

reducido4 :: Camino -> Camino

reducido4 ds = reverse (aux ([],ds)) where

aux (N:xs, S:ys) = aux (xs,ys)

aux (S:xs, N:ys) = aux (xs,ys)

aux (E:xs, O:ys) = aux (xs,ys)

aux (O:xs, E:ys) = aux (xs,ys)

aux ( xs, y:ys) = aux (y:xs,ys)

aux ( xs, []) = xs

-- Comparación de eficiencia

-- ghci> reducido1 (take (10^6) (cycle [N,E,O,S]))

-- []

-- (3.87 secs, 460160736 bytes)

-- ghci> reducido2 (take (10^6) (cycle [N,E,O,S]))

-- []

-- (1.16 secs, 216582880 bytes)

-- ghci> reducido3 (take (10^6) (cycle [N,E,O,S]))

-- []

-- (0.58 secs, 98561872 bytes)

-- ghci> reducido4 (take (10^6) (cycle [N,E,O,S]))

-- []

-- (0.64 secs, 176154640 bytes)

-- ghci> reducido3 (take (10^7) (cycle [N,E,O,S]))

-- []

-- (5.43 secs, 962694784 bytes)

-- ghci> reducido4 (take (10^7) (cycle [N,E,O,S]))

-- []

-- (9.29 secs, 1722601528 bytes)

-- ghci> length $ reducido3 (take 2000000 $ cycle [N,O,N,S,E,N,S,O,S,S])

-- 400002

-- (4.52 secs, 547004960 bytes)

-- ghci> length $ reducido4 (take 2000000 $ cycle [N,O,N,S,E,N,S,O,S,S])

-- 400002

-- ghci> let n=10^6 in reducido1 (replicate n N ++ replicate n S)

-- []

-- (7.35 secs, 537797096 bytes)

-- ghci> let n=10^6 in reducido2 (replicate n N ++ replicate n S)

-- []

-- (2.30 secs, 244553404 bytes)

-- ghci> let n=10^6 in reducido3 (replicate n N ++ replicate n S)

-- []

-- (8.08 secs, 545043608 bytes)

-- ghci> let n=10^6 in reducido4 (replicate n N ++ replicate n S)

-- []

-- (1.96 secs, 205552240 bytes)

Subexpresiones aritméticas

PorJosé A. Alonso 4-junio-20202-enero-2021

Las expresiones aritméticas pueden representarse usando el siguiente tipo de datos

   data Expr = N Int | S Expr Expr | P Expr Expr  
     deriving (Eq, Ord, Show)

1 2	data Expr = N Int \| S Expr Expr \| P Expr Expr deriving (Eq, Ord, Show)

Por ejemplo, la expresión 2*(3+7) se representa por

   P (N 2) (S (N 3) (N 7))

1	P (N 2) (S (N 3) (N 7))

Definir la función

   subexpresiones :: Expr -> Set Expr

1	subexpresiones :: Expr -> Set Expr

tal que (subexpresiones e) es el conjunto de las subexpresiones de e. Por ejemplo,

   λ> subexpresiones (S (N 2) (N 3))
   fromList [N 2,N 3,S (N 2) (N 3)]
   λ> subexpresiones (P (S (N 2) (N 2)) (N 7))
   fromList [N 2,N 7,S (N 2) (N 2),P (S (N 2) (N 2)) (N 7)]

λ> subexpresiones (S (N 2) (N 3))

fromList [N 2,N 3,S (N 2) (N 3)]

λ> subexpresiones (P (S (N 2) (N 2)) (N 7))

fromList [N 2,N 7,S (N 2) (N 2),P (S (N 2) (N 2)) (N 7)]

Soluciones

import Data.Set

data Expr = N Int | S Expr Expr | P Expr Expr  
  deriving (Eq, Ord, Show)

subexpresiones :: Expr -> Set Expr
subexpresiones (N x)   = singleton (N x)
subexpresiones (S i d) =
  S i d `insert` (subexpresiones i `union` subexpresiones d)
subexpresiones (P i d) =
  P i d `insert` (subexpresiones i `union` subexpresiones d)

import Data.Set

data Expr = N Int | S Expr Expr | P Expr Expr

deriving (Eq, Ord, Show)

subexpresiones :: Expr -> Set Expr

subexpresiones (N x) = singleton (N x)

subexpresiones (S i d) =

S i d `insert` (subexpresiones i `union` subexpresiones d)

subexpresiones (P i d) =

P i d `insert` (subexpresiones i `union` subexpresiones d)

Número como suma de sus dígitos

PorJosé A. Alonso 3-junio-20202-enero-2021

El número 23 se puede escribir de 4 formas como suma de sus dígitos

   2 + 2 + 2 + 2 + 2 + 2 + 2 + 2 + 2 + 2 + 3
   2 + 2 + 2 + 2 + 2 + 2 + 2 + 3 + 3 + 3
   2 + 2 + 2 + 2 + 3 + 3 + 3 + 3 + 3
   2 + 3 + 3 + 3 + 3 + 3 + 3 + 3

2 + 2 + 2 + 2 + 2 + 2 + 2 + 2 + 2 + 2 + 3

2 + 2 + 2 + 2 + 2 + 2 + 2 + 3 + 3 + 3

2 + 2 + 2 + 2 + 3 + 3 + 3 + 3 + 3

2 + 3 + 3 + 3 + 3 + 3 + 3 + 3

La de menor número de sumando es la última, que tiene 8 sumandos.

Definir las funciones

   minimoSumandosDigitos        :: Integer -> Integer
   graficaMinimoSumandosDigitos :: Integer -> IO ()

1 2	minimoSumandosDigitos :: Integer -> Integer graficaMinimoSumandosDigitos :: Integer -> IO ()

tales que

(minimoSumandosDigitos n) es el menor número de dígitos de n cuya suma es n. Por ejemplo,

     minimoSumandosDigitos 23    ==  8
     minimoSumandosDigitos 232   ==  78
     minimoSumandosDigitos 2323  ==  775
     map minimoSumandosDigitos [10..20] == [10,11,6,5,5,3,6,5,4,3,10]

minimoSumandosDigitos 23 == 8

minimoSumandosDigitos 232 == 78

minimoSumandosDigitos 2323 == 775

map minimoSumandosDigitos [10..20] == [10,11,6,5,5,3,6,5,4,3,10]

(graficaMinimoSumandosDigitos n) dibuja la gráfica de (minimoSumandosDigitos k) par los k primeros números naturales. Por ejemplo, (graficaMinimoSumandosDigitos 300) dibuja

Soluciones

import Test.QuickCheck
import Graphics.Gnuplot.Simple
import Data.List (nub, genericLength, sort)
import Data.Array (array, (!))

minimoSumandosDigitos :: Integer -> Integer
minimoSumandosDigitos n =
  minimoSumandos (digitos n) n

-- (digitos n) es el conjunto de los dígitos no nulos de n. Por ejemplo,
--    digitos 2032  ==  [2,3]
digitos :: Integer -> [Integer]
digitos n =
  nub [read [c] | c <- show n, c /= '0']

-- (minimoSumandos xs n) es el menor número de elementos de la lista de
-- enteros positivos xs (con posibles repeticiones) cuya suma es n. Por
-- ejemplo, 
--    minimoSumandos [7,2,4] 11  ==  2
minimoSumandos :: [Integer] -> Integer -> Integer
minimoSumandos xs n =
  minimum (map genericLength (sumas xs n))

-- (sumas xs n) es la lista de elementos de la lista de enteros
-- positivos xs (con posibles repeticiones) cuya suma es n. Por ejemplo,  
--    sumas [7,2,4] 11  ==  [[7,2,2],[7,4]]
sumas :: [Integer] -> Integer -> [[Integer]]
sumas [] 0 = [[]]
sumas [] _ = []
sumas (x:xs) n
  | x <= n    = map (x:) (sumas (x:xs) (n-x)) ++ sumas xs n
  | otherwise = sumas xs n

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

minimoSumandosDigitos2 :: Integer -> Integer
minimoSumandosDigitos2 n = aux n 
  where
    aux 0 = 0
    aux k = 1 + minimo [aux (k - x) | x <- ds,  k >= x]
    ds    = digitos n
    infinito = 10^100
    minimo xs | null xs   = infinito
              | otherwise = minimum xs

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

minimoSumandosDigitos3 :: Integer -> Integer
minimoSumandosDigitos3 n = v ! n
  where
    v   = array (0,n) [(i,f i) | i <- [0..n]]
    f 0 = 0
    f k = 1 + minimo [v ! (k - x) | x <- ds, k >= x]
    ds       = digitos n
    infinito = 10^100
    minimo xs | null xs   = infinito
              | otherwise = minimum xs
        
-- Equivalencia de las definiciones
-- ================================

-- La propiedad es
prop_minimoSumandosDigitos :: Positive Integer -> Bool
prop_minimoSumandosDigitos (Positive n) =
  r1 == r2 && r2 == r3
  where
    r1 = minimoSumandosDigitos n
    r2 = minimoSumandosDigitos n
    r3 = minimoSumandosDigitos n

-- La comprobación es
--    λ> quickCheckWith (stdArgs {maxSize=9}) prop_minimoSumandosDigitos
--    +++ OK, passed 100 tests.

-- Definición de graficaMinimoSumandosDigitos
-- ==========================================

graficaMinimoSumandosDigitos :: Integer -> IO ()
graficaMinimoSumandosDigitos n =
  plotList [ Key Nothing
           -- , PNG "Numero_como_suma_de_sus_digitos.png"
           ]
           [minimoSumandosDigitos k | k <- [0..n-1]]

import Test.QuickCheck

import Graphics.Gnuplot.Simple

import Data.List (nub, genericLength, sort)

import Data.Array (array, (!))

minimoSumandosDigitos :: Integer -> Integer

minimoSumandosDigitos n =

minimoSumandos (digitos n) n

-- (digitos n) es el conjunto de los dígitos no nulos de n. Por ejemplo,

-- digitos 2032 == [2,3]

digitos :: Integer -> [Integer]

digitos n =

nub [read [c] | c <- show n, c /= '0']

-- (minimoSumandos xs n) es el menor número de elementos de la lista de

-- enteros positivos xs (con posibles repeticiones) cuya suma es n. Por

-- ejemplo,

-- minimoSumandos [7,2,4] 11 == 2

minimoSumandos :: [Integer] -> Integer -> Integer

minimoSumandos xs n =

minimum (map genericLength (sumas xs n))

-- (sumas xs n) es la lista de elementos de la lista de enteros

-- positivos xs (con posibles repeticiones) cuya suma es n. Por ejemplo,

-- sumas [7,2,4] 11 == [[7,2,2],[7,4]]

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

sumas [] 0 = [[]]

sumas [] _ = []

sumas (x:xs) n

| x <= n = map (x:) (sumas (x:xs) (n-x)) ++ sumas xs n

| otherwise = sumas xs n

-- 2ª solución

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

minimoSumandosDigitos2 :: Integer -> Integer

minimoSumandosDigitos2 n = aux n

where

aux 0 = 0

aux k = 1 + minimo [aux (k - x) | x <- ds, k >= x]

ds = digitos n

infinito = 10^100

minimo xs | null xs = infinito

| otherwise = minimum xs

-- 3ª solución

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

minimoSumandosDigitos3 :: Integer -> Integer

minimoSumandosDigitos3 n = v ! n

where

v = array (0,n) [(i,f i) | i <- [0..n]]

f 0 = 0

f k = 1 + minimo [v ! (k - x) | x <- ds, k >= x]

ds = digitos n

infinito = 10^100

minimo xs | null xs = infinito

| otherwise = minimum xs

-- Equivalencia de las definiciones

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

-- La propiedad es

prop_minimoSumandosDigitos :: Positive Integer -> Bool

prop_minimoSumandosDigitos (Positive n) =

r1 == r2 && r2 == r3

where

r1 = minimoSumandosDigitos n

r2 = minimoSumandosDigitos n

r3 = minimoSumandosDigitos n

-- La comprobación es

-- λ> quickCheckWith (stdArgs {maxSize=9}) prop_minimoSumandosDigitos

-- +++ OK, passed 100 tests.

-- Definición de graficaMinimoSumandosDigitos

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

graficaMinimoSumandosDigitos :: Integer -> IO ()

graficaMinimoSumandosDigitos n =

plotList [ Key Nothing

-- , PNG "Numero_como_suma_de_sus_digitos.png"

]

[minimoSumandosDigitos k | k <- [0..n-1]]

Cambio con el menor número de monedas

PorJosé A. Alonso 2-junio-202026-marzo-2022

El problema del cambio con el menor número de monedas consiste en, dada una lista ms de tipos de monedas (con infinitas monedas de cada tipo) y una cantidad objetivo x, calcular el menor número de monedas de ms cuya suma es x. Por ejemplo, con monedas de 1, 3 y 4 céntimos se puede obtener 6 céntimos de 4 formas

   1, 1, 1, 1, 1, 1
   1, 1, 1, 3
   1, 1, 4
   3, 3

1, 1, 1, 1, 1, 1

1, 1, 1, 3

1, 1, 4

3, 3

El menor número de monedas que se necesita es 2. En cambio, con monedas de 2, 5 y 10 es imposible obtener 3.

Definir

   monedas :: [Int] -> Int -> Maybe Int

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

tal que (monedas ms x) es el menor número de monedas de ms cuya suma es x, si es posible obtener dicha suma y es Nothing en caso contrario. Por ejemplo,

   monedas [1,3,4]  6                    ==  Just 2
   monedas [2,5,10] 3                    ==  Nothing
   monedas [1,2,5,10,20,50,100,200] 520  ==  Just 4

monedas [1,3,4] 6 == Just 2

monedas [2,5,10] 3 == Nothing

monedas [1,2,5,10,20,50,100,200] 520 == Just 4

Soluciones

import Data.Array ((!), array)

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

monedas :: [Int] -> Int -> Maybe Int
monedas ms x
  | null cs   = Nothing
  | otherwise = Just (minimum (map length cs))
  where cs = cambios ms x

-- (cambios ms x) es la lista de las foemas de obtener x sumando monedas
-- de ms. Por ejemplo,
--   λ> cambios [1,5,10] 12
--   [[1,1,1,1,1,1,1,1,1,1,1,1],[1,1,1,1,1,1,1,5],[1,1,5,5],[1,1,10]]
--   λ> cambios [2,5,10] 3
--   []
--   λ> cambios [1,3,4] 6
--   [[1,1,1,1,1,1],[1,1,1,3],[1,1,4],[3,3]]
cambios :: [Int] -> Int -> [[Int]]
cambios _      0 = [[]]
cambios []     _ = []
cambios (k:ks) m
  | m < k     = []
  | otherwise = [k:zs | zs <- cambios (k:ks) (m - k)] ++
                cambios ks m

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

monedas2 :: [Int] -> Int -> Maybe Int
monedas2 ms n
  | sol == infinito = Nothing
  | otherwise       = Just sol
  where
    sol = aux n
    aux 0 = 0
    aux k = siguiente (minimo [aux (k - x) | x <- ms,  k >= x])

infinito :: Int
infinito = 10^30

minimo :: [Int] -> Int
minimo [] = infinito
minimo xs = minimum xs

siguiente :: Int -> Int
siguiente x | x == infinito = infinito
            | otherwise     = 1 + x

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

monedas3 :: [Int] -> Int -> Maybe Int
monedas3 ms n  
  | sol == infinito = Nothing
  | otherwise       = Just sol
  where
    sol = v ! n
    v   = array (0,n) [(i,f i) | i <- [0..n]]
    f 0 = 0
    f k = siguiente (minimo [v ! (k - x) | x <- ms, k >= x])

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

--    λ> monedas [1,2,5,10,20,50,100,200] 27
--    Just 3
--    (0.02 secs, 871,144 bytes)
--    λ> monedas2 [1,2,5,10,20,50,100,200] 27
--    Just 3
--    (15.44 secs, 1,866,519,080 bytes)
--    λ> monedas3 [1,2,5,10,20,50,100,200] 27
--    Just 3
--    (0.01 secs, 157,232 bytes)
--    
--    λ> monedas [1,2,5,10,20,50,100,200] 188
--    Just 7
--    (14.20 secs, 1,845,293,080 bytes)
--    λ> monedas3 [1,2,5,10,20,50,100,200] 188
--    Just 7
--    (0.01 secs, 623,376 bytes)

import Data.Array ((!), array)

-- 1ª solución

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

monedas :: [Int] -> Int -> Maybe Int

monedas ms x

| null cs = Nothing

| otherwise = Just (minimum (map length cs))

where cs = cambios ms x

-- (cambios ms x) es la lista de las foemas de obtener x sumando monedas

-- de ms. Por ejemplo,

-- λ> cambios [1,5,10] 12

-- [[1,1,1,1,1,1,1,1,1,1,1,1],[1,1,1,1,1,1,1,5],[1,1,5,5],[1,1,10]]

-- λ> cambios [2,5,10] 3

-- []

-- λ> cambios [1,3,4] 6

-- [[1,1,1,1,1,1],[1,1,1,3],[1,1,4],[3,3]]

cambios :: [Int] -> Int -> [[Int]]

cambios _ 0 = [[]]

cambios [] _ = []

cambios (k:ks) m

| m < k = []

| otherwise = [k:zs | zs <- cambios (k:ks) (m - k)] ++

cambios ks m

-- 2ª solución

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

monedas2 :: [Int] -> Int -> Maybe Int

monedas2 ms n

| sol == infinito = Nothing

| otherwise = Just sol

where

sol = aux n

aux 0 = 0

aux k = siguiente (minimo [aux (k - x) | x <- ms, k >= x])

infinito :: Int

infinito = 10^30

minimo :: [Int] -> Int

minimo [] = infinito

minimo xs = minimum xs

siguiente :: Int -> Int

siguiente x | x == infinito = infinito

| otherwise = 1 + x

-- 3ª solución

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

monedas3 :: [Int] -> Int -> Maybe Int

monedas3 ms n

| sol == infinito = Nothing

| otherwise = Just sol

where

sol = v ! n

v = array (0,n) [(i,f i) | i <- [0..n]]

f 0 = 0

f k = siguiente (minimo [v ! (k - x) | x <- ms, k >= x])

-- Comparación de eficiencia

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

-- λ> monedas [1,2,5,10,20,50,100,200] 27

-- Just 3

-- (0.02 secs, 871,144 bytes)

-- λ> monedas2 [1,2,5,10,20,50,100,200] 27

-- Just 3

-- (15.44 secs, 1,866,519,080 bytes)

-- λ> monedas3 [1,2,5,10,20,50,100,200] 27

-- Just 3

-- (0.01 secs, 157,232 bytes)

-- λ> monedas [1,2,5,10,20,50,100,200] 188

-- Just 7

-- (14.20 secs, 1,845,293,080 bytes)

-- λ> monedas3 [1,2,5,10,20,50,100,200] 188

-- Just 7

-- (0.01 secs, 623,376 bytes)

La sucesión ECG

PorJosé A. Alonso 1-junio-20202-enero-2021

La sucesión ECG estás definida por a(1) = 1, a(2) = 2 y, para n >= 3, a(n) es el menor natural que aún no está en la sucesión tal que a(n) tiene algún divisor común con a(n-1).

Los primeros términos de la sucesión son 1, 2, 4, 6, 3, 9, 12, 8, 10, 5, 15, …

Al dibujar su gráfica, se parece a la de los electrocardiogramas (abreviadamente, ECG). Por ello, la sucesión se conoce como la sucesión ECG.

Definir las funciones

   sucECG :: [Integer]
   graficaSucECG :: Int -> IO ()

1 2	sucECG :: [Integer] graficaSucECG :: Int -> IO ()

tales que

sucECG es la lista de los términos de la sucesión ECG. Por ejemplo,

     λ> take 20 sucECG
     [1,2,4,6,3,9,12,8,10,5,15,18,14,7,21,24,16,20,22,11]
     λ> sucECG !! 6000
     6237

λ> take 20 sucECG

[1,2,4,6,3,9,12,8,10,5,15,18,14,7,21,24,16,20,22,11]

λ> sucECG !! 6000

6237

(graficaSucECG n) dibuja la gráfica de los n primeros términos de la sucesión ECG. Por ejemplo, (graficaSucECG 160) dibuja

Soluciones

import Data.List (delete)
import Graphics.Gnuplot.Simple

sucECG :: [Integer]
sucECG = 1 : ecg 2 [2..]
  where ecg x zs = f zs
          where f (y:ys) | gcd x y > 1 = y : ecg y (delete y zs)
                         | otherwise   = f ys

graficaSucECG :: Int -> IO ()
graficaSucECG n =
  plotList [ Key Nothing
           , PNG "La_sucesion_ECG.png" 
           ]
           (take n sucECG)

import Data.List (delete)

import Graphics.Gnuplot.Simple

sucECG :: [Integer]

sucECG = 1 : ecg 2 [2..]

where ecg x zs = f zs

where f (y:ys) | gcd x y > 1 = y : ecg y (delete y zs)

| otherwise = f ys

graficaSucECG :: Int -> IO ()

graficaSucECG n =

plotList [ Key Nothing

, PNG "La_sucesion_ECG.png"

]

(take n sucECG)

Caminos en un grafo

PorJosé A. Alonso 28-mayo-20204-junio-2020

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

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)

Sin ceros consecutivos

PorJosé A. Alonso 27-mayo-20203-junio-2020

Definir la función

   sinDobleCero :: Int -> [[Int]]

1	sinDobleCero :: Int -> [[Int]]

tal que (sinDobleCero n) es la lista de las listas de longitud n formadas por el 0 y el 1 tales que no contiene dos ceros consecutivos. Por ejemplo,

   ghci> sinDobleCero 2
   [[1,0],[1,1],[0,1]]
   ghci> sinDobleCero 3
   [[1,1,0],[1,1,1],[1,0,1],[0,1,0],[0,1,1]]
   ghci> sinDobleCero 4
   [[1,1,1,0],[1,1,1,1],[1,1,0,1],[1,0,1,0],[1,0,1,1],
    [0,1,1,0],[0,1,1,1],[0,1,0,1]]

ghci> sinDobleCero 2

[[1,0],[1,1],[0,1]]

ghci> sinDobleCero 3

[[1,1,0],[1,1,1],[1,0,1],[0,1,0],[0,1,1]]

ghci> sinDobleCero 4

[[1,1,1,0],[1,1,1,1],[1,1,0,1],[1,0,1,0],[1,0,1,1],

[0,1,1,0],[0,1,1,1],[0,1,0,1]]

Soluciones

sinDobleCero :: Int -> [[Int]]
sinDobleCero 0 = [[]]
sinDobleCero 1 = [[0],[1]]
sinDobleCero n = [1:xs | xs <- sinDobleCero (n-1)] ++
                 [0:1:ys | ys <- sinDobleCero (n-2)]

sinDobleCero :: Int -> [[Int]]

sinDobleCero 0 = [[]]

sinDobleCero 1 = [[0],[1]]

sinDobleCero n = [1:xs | xs <- sinDobleCero (n-1)] ++

[0:1:ys | ys <- sinDobleCero (n-2)]

Las sucesiones de Loomis

PorJosé A. Alonso 22-mayo-202029-mayo-2020

La sucesión de Loomis generada por un número entero positivo x es la sucesión cuyos términos se definen por

f(0) es x
f(n) es la suma de f(n-1) y el producto de los dígitos no nulos de f(n-1)

Los primeros términos de las primeras sucesiones de Loomis son

Generada por 1: 1, 2, 4, 8, 16, 22, 26, 38, 62, 74, 102, 104, 108, 116, 122, …
Generada por 2: 2, 4, 8, 16, 22, 26, 38, 62, 74, 102, 104, 108, 116, 122, 126, …
Generada por 3: 3, 6, 12, 14, 18, 26, 38, 62, 74, 102, 104, 108, 116, 122, 126, …
Generada por 4: 4, 8, 16, 22, 26, 38, 62, 74, 102, 104, 108, 116, 122, 126, 138, …
Generada por 5: 5, 10, 11, 12, 14, 18, 26, 38, 62, 74, 102, 104, 108, 116, 122, …

Se observa que a partir de un término todas coinciden con la generada por 1. Dicho término se llama el punto de convergencia. Por ejemplo,

la generada por 2 converge a 2
la generada por 3 converge a 26
la generada por 4 converge a 4
la generada por 5 converge a 26

Definir las siguientes funciones

   sucLoomis           :: Integer -> [Integer]
   convergencia        :: Integer -> Integer
   graficaConvergencia :: [Integer] -> IO ()

sucLoomis :: Integer -> [Integer]

convergencia :: Integer -> Integer

graficaConvergencia :: [Integer] -> IO ()

tales que

(sucLoomis x) es la sucesión de Loomis generada por x. Por ejemplo,

     λ> take 15 (sucLoomis 1)
     [1,2,4,8,16,22,26,38,62,74,102,104,108,116,122]
     λ> take 15 (sucLoomis 2)
     [2,4,8,16,22,26,38,62,74,102,104,108,116,122,126]
     λ> take 15 (sucLoomis 3)
     [3,6,12,14,18,26,38,62,74,102,104,108,116,122,126]
     λ> take 15 (sucLoomis 4)
     [4,8,16,22,26,38,62,74,102,104,108,116,122,126,138]
     λ> take 15 (sucLoomis 5)
     [5,10,11,12,14,18,26,38,62,74,102,104,108,116,122]
     λ> take 15 (sucLoomis 20)
     [20,22,26,38,62,74,102,104,108,116,122,126,138,162,174]
     λ> take 15 (sucLoomis 100)
     [100,101,102,104,108,116,122,126,138,162,174,202,206,218,234]
     λ> sucLoomis 1 !! (2*10^5)
     235180736652

λ> take 15 (sucLoomis 1)

[1,2,4,8,16,22,26,38,62,74,102,104,108,116,122]

λ> take 15 (sucLoomis 2)

[2,4,8,16,22,26,38,62,74,102,104,108,116,122,126]

λ> take 15 (sucLoomis 3)

[3,6,12,14,18,26,38,62,74,102,104,108,116,122,126]

λ> take 15 (sucLoomis 4)

[4,8,16,22,26,38,62,74,102,104,108,116,122,126,138]

λ> take 15 (sucLoomis 5)

[5,10,11,12,14,18,26,38,62,74,102,104,108,116,122]

λ> take 15 (sucLoomis 20)

[20,22,26,38,62,74,102,104,108,116,122,126,138,162,174]

λ> take 15 (sucLoomis 100)

[100,101,102,104,108,116,122,126,138,162,174,202,206,218,234]

λ> sucLoomis 1 !! (2*10^5)

235180736652

(convergencia x) es el término de convergencia de la sucesioń de Loomis generada por x xon la geerada por 1. Por ejemplo,

     convergencia  2      ==  2
     convergencia  3      ==  26
     convergencia  4      ==  4
     convergencia 17      ==  38
     convergencia 19      ==  102
     convergencia 43      ==  162
     convergencia 27      ==  202
     convergencia 58      ==  474
     convergencia 63      ==  150056
     convergencia 81      ==  150056
     convergencia 89      ==  150056
     convergencia (10^12) ==  1000101125092

convergencia 2 == 2

convergencia 3 == 26

convergencia 4 == 4

convergencia 17 == 38

convergencia 19 == 102

convergencia 43 == 162

convergencia 27 == 202

convergencia 58 == 474

convergencia 63 == 150056

convergencia 81 == 150056

convergencia 89 == 150056

convergencia (10^12) == 1000101125092

(graficaConvergencia xs) dibuja la gráfica de los términos de convergencia de las sucesiones de Loomis generadas por los elementos de xs. Por ejemplo, (graficaConvergencia ([1..50]) dibuja

y graficaConvergencia ([1..148] \ [63,81,89,137]) dibuja

Soluciones

import Data.List               ((\\))
import Data.Char               (digitToInt)
import Graphics.Gnuplot.Simple (plotList, Attribute (Key, Title, XRange, PNG))

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

sucLoomis :: Integer -> [Integer]
sucLoomis x = map (loomis x) [0..]

loomis :: Integer -> Integer -> Integer
loomis x 0 = x
loomis x n = y + productoDigitosNoNulos y
  where y = loomis x (n-1)

productoDigitosNoNulos :: Integer -> Integer
productoDigitosNoNulos = product . digitosNoNulos

digitosNoNulos :: Integer -> [Integer]
digitosNoNulos x =
  [read [c] | c <- show x, c /= '0']

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

sucLoomis2 :: Integer -> [Integer]
sucLoomis2 = iterate siguienteLoomis 

siguienteLoomis :: Integer -> Integer
siguienteLoomis y = y + productoDigitosNoNulos y

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

sucLoomis3 :: Integer -> [Integer]
sucLoomis3 =
  iterate ((+) <*> product .
           map (toInteger . digitToInt) .
           filter (/= '0') . show)

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

--    λ> sucLoomis 1 !! 30000
--    6571272766
--    (2.45 secs, 987,955,944 bytes)
--    λ> sucLoomis2 1 !! 30000
--    6571272766
--    (2.26 secs, 979,543,328 bytes)
--    λ> sucLoomis3 1 !! 30000
--    6571272766
--    (0.31 secs, 88,323,832 bytes)

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

convergencia1 :: Integer -> Integer
convergencia1 x =
  head (dropWhile noEnSucLoomisDe1 (sucLoomis x))

noEnSucLoomisDe1 :: Integer -> Bool
noEnSucLoomisDe1 x = not (pertenece x sucLoomisDe1)

sucLoomisDe1 :: [Integer]
sucLoomisDe1 = sucLoomis 1

pertenece :: Integer -> [Integer] -> Bool
pertenece x ys =
  x == head (dropWhile (<x) ys)

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

convergencia2 :: Integer -> Integer
convergencia2 = aux (sucLoomis3 1) . sucLoomis3
 where aux as@(x:xs) bs@(y:ys) | x == y    = x
                               | x < y     = aux xs bs
                               | otherwise = aux as ys

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

convergencia3 :: Integer -> Integer
convergencia3 = head . interseccion (sucLoomis3 1) . sucLoomis3
 
-- (interseccion xs ys) es la intersección entre las listas ordenadas xs
-- e ys. Por ejemplo,
--    λ> take 10 (interseccion (sucLoomis3 1) (sucLoomis3 2))
--    [2,4,8,16,22,26,38,62,74,102]
interseccion :: Ord a => [a] -> [a] -> [a]
interseccion = aux
  where aux as@(x:xs) bs@(y:ys) = case compare x y of
                                    LT ->     aux xs bs
                                    EQ -> x : aux xs ys
                                    GT ->     aux as ys
        aux _         _         = []                           

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

convergencia4 :: Integer -> Integer
convergencia4 x = perteneceA (sucLoomis3 x) 1
  where perteneceA (y:ys) n | y == c    = y
                            | otherwise = perteneceA ys c
          where c = head $ dropWhile (< y) $ sucLoomis3 n

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

--    λ> convergencia1 (10^4)
--    150056
--    (2.94 secs, 1,260,809,808 bytes)
--    λ> convergencia2 (10^4)
--    150056
--    (0.03 secs, 700,240 bytes)
--    λ> convergencia3 (10^4)
--    150056
--    (0.03 secs, 1,165,496 bytes)
--    λ> convergencia4 (10^4)
--    150056
--    (0.02 secs, 1,119,648 bytes)
--    
--    λ> convergencia2 (10^12)
--    1000101125092
--    (1.81 secs, 714,901,080 bytes)
--    λ> convergencia3 (10^12)
--    1000101125092
--    (1.92 secs, 744,932,184 bytes)
--    λ> convergencia4 (10^12)
--    1000101125092
--    (1.82 secs, 941,053,328 bytes)

-- Definición de graficaConvergencia
-- ==================================

graficaConvergencia :: [Integer] -> IO ()
graficaConvergencia xs =
  plotList [ Key Nothing
           , Title "Convergencia de sucesiones de Loomis"
           , XRange (fromIntegral (minimum xs),fromIntegral (maximum xs))
           , PNG "Las_sucesiones_de_Loomis_2.png"
           ]
           [(x,convergencia2 x) | x <- xs]

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

import Data.List ((\\))

import Data.Char (digitToInt)

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

-- 1ª definición de sucLoomis

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

sucLoomis :: Integer -> [Integer]

sucLoomis x = map (loomis x) [0..]

loomis :: Integer -> Integer -> Integer

loomis x 0 = x

loomis x n = y + productoDigitosNoNulos y

where y = loomis x (n-1)

productoDigitosNoNulos :: Integer -> Integer

productoDigitosNoNulos = product . digitosNoNulos

digitosNoNulos :: Integer -> [Integer]

digitosNoNulos x =

[read [c] | c <- show x, c /= '0']

-- 2ª definición de sucLoomis

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

sucLoomis2 :: Integer -> [Integer]

sucLoomis2 = iterate siguienteLoomis

siguienteLoomis :: Integer -> Integer

siguienteLoomis y = y + productoDigitosNoNulos y

-- 3ª definición de sucLoomis

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

sucLoomis3 :: Integer -> [Integer]

sucLoomis3 =

iterate ((+) <*> product .

map (toInteger . digitToInt) .

filter (/= '0') . show)

-- Comparación de eficiencia

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

-- λ> sucLoomis 1 !! 30000

-- 6571272766

-- (2.45 secs, 987,955,944 bytes)

-- λ> sucLoomis2 1 !! 30000

-- 6571272766

-- (2.26 secs, 979,543,328 bytes)

-- λ> sucLoomis3 1 !! 30000

-- 6571272766

-- (0.31 secs, 88,323,832 bytes)

-- 1ª definición de convergencia

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

convergencia1 :: Integer -> Integer

convergencia1 x =

head (dropWhile noEnSucLoomisDe1 (sucLoomis x))

noEnSucLoomisDe1 :: Integer -> Bool

noEnSucLoomisDe1 x = not (pertenece x sucLoomisDe1)

sucLoomisDe1 :: [Integer]

sucLoomisDe1 = sucLoomis 1

pertenece :: Integer -> [Integer] -> Bool

pertenece x ys =

x == head (dropWhile (<x) ys)

-- 2ª definición de convergencia

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

convergencia2 :: Integer -> Integer

convergencia2 = aux (sucLoomis3 1) . sucLoomis3

where aux as@(x:xs) bs@(y:ys) | x == y = x

| x < y = aux xs bs

| otherwise = aux as ys

-- 3ª definición de convergencia

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

convergencia3 :: Integer -> Integer

convergencia3 = head . interseccion (sucLoomis3 1) . sucLoomis3

-- (interseccion xs ys) es la intersección entre las listas ordenadas xs

-- e ys. Por ejemplo,

-- λ> take 10 (interseccion (sucLoomis3 1) (sucLoomis3 2))

-- [2,4,8,16,22,26,38,62,74,102]

interseccion :: Ord a => [a] -> [a] -> [a]

interseccion = aux

where aux as@(x:xs) bs@(y:ys) = case compare x y of

LT -> aux xs bs

EQ -> x : aux xs ys

GT -> aux as ys

aux _ _ = []

-- 4ª definición de convergencia

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

convergencia4 :: Integer -> Integer

convergencia4 x = perteneceA (sucLoomis3 x) 1

where perteneceA (y:ys) n | y == c = y

| otherwise = perteneceA ys c

where c = head $ dropWhile (< y) $ sucLoomis3 n

-- Comparación de eficiencia

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

-- λ> convergencia1 (10^4)

-- 150056

-- (2.94 secs, 1,260,809,808 bytes)

-- λ> convergencia2 (10^4)

-- 150056

-- (0.03 secs, 700,240 bytes)

-- λ> convergencia3 (10^4)

-- 150056

-- (0.03 secs, 1,165,496 bytes)

-- λ> convergencia4 (10^4)

-- 150056

-- (0.02 secs, 1,119,648 bytes)

-- λ> convergencia2 (10^12)

-- 1000101125092

-- (1.81 secs, 714,901,080 bytes)

-- λ> convergencia3 (10^12)

-- 1000101125092

-- (1.92 secs, 744,932,184 bytes)

-- λ> convergencia4 (10^12)

-- 1000101125092

-- (1.82 secs, 941,053,328 bytes)

-- Definición de graficaConvergencia

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

graficaConvergencia :: [Integer] -> IO ()

graficaConvergencia xs =

plotList [ Key Nothing

, Title "Convergencia de sucesiones de Loomis"

, XRange (fromIntegral (minimum xs),fromIntegral (maximum xs))

, PNG "Las_sucesiones_de_Loomis_2.png"

]

[(x,convergencia2 x) | x <- xs]

Espacio de estados del problema de las N reinas

PorJosé A. Alonso 21-mayo-202028-mayo-2020

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

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

Números de Perrin

PorJosé A. Alonso 19-mayo-202026-mayo-2020

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

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

-- 4ª solución
sucPerrin4 :: [Integer]
sucPerrin4 = [vectorPerrin n ! n | n <- [0..]]

vectorPerrin :: Integer -> Array Integer Integer
vectorPerrin n = v where
  v = array (0,n) [(i,f i) | i <- [0..n]]
  f 0 = 3
  f 1 = 0
  f 2 = 2
  f i = v ! (i-2) + v ! (i-3)

-- Comparación de eficiencia
--    λ> length (show (sucPerrin1 !! (3*10^5)))
--    36638
--    (1.62 secs, 2,366,238,984 bytes)
--    λ> length (show (sucPerrin2 !! (3*10^5)))
--    36638
--    (1.40 secs, 2,428,701,384 bytes)
--    λ> length (show (sucPerrin3 !! (3*10^5)))
--    36638
--    (1.14 secs, 2,409,504,864 bytes)
--    λ> length (show (sucPerrin4 !! (3*10^5)))
--    36638
--    (1.78 secs, 2,585,400,776 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))

-- 4ª solución

sucPerrin4 :: [Integer]

sucPerrin4 = [vectorPerrin n ! n | n <- [0..]]

vectorPerrin :: Integer -> Array Integer Integer

vectorPerrin n = v where

v = array (0,n) [(i,f i) | i <- [0..n]]

f 0 = 3

f 1 = 0

f 2 = 2

f i = v ! (i-2) + v ! (i-3)

-- Comparación de eficiencia

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

-- 36638

-- (1.62 secs, 2,366,238,984 bytes)

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

-- 36638

-- (1.40 secs, 2,428,701,384 bytes)

-- λ> length (show (sucPerrin3 !! (3*10^5)))

-- 36638

-- (1.14 secs, 2,409,504,864 bytes)

-- λ> length (show (sucPerrin4 !! (3*10^5)))

-- 36638

-- (1.78 secs, 2,585,400,776 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

Cadenas de divisores

PorJosé A. Alonso 14-mayo-202021-mayo-2020

Una cadena de divisores de un número n es una lista donde cada elemento es un divisor de su siguiente elemento en la lista. Por ejemplo, las cadenas de divisores de 12 son [2,4,12], [2,6,12], [2,12], [3,6,12], [3,12], [4,12], [6,12] y [12].

Definir la función

   cadenasDivisores :: Int -> [[Int]]

1	cadenasDivisores :: Int -> [[Int]]

tal que (cadenasDivisores n) es la lista de las cadenas de divisores de n. Por ejemplo,

   λ> cadenasDivisores 12
   [[2,4,12],[2,6,12],[2,12],[3,6,12],[3,12],[4,12],[6,12],[12]]
   λ> length (cadenaDivisores 48)
   48
   λ> length (cadenaDivisores 120)
   132

λ> cadenasDivisores 12

[[2,4,12],[2,6,12],[2,12],[3,6,12],[3,12],[4,12],[6,12],[12]]

λ> length (cadenaDivisores 48)

λ> length (cadenaDivisores 120)

132

Soluciones

import Data.List (sort)
import Data.Numbers.Primes (isPrime)

-- 1ª definición
-- =============

cadenasDivisores :: Int -> [[Int]]
cadenasDivisores n = sort (extiendeLista [[n]])
    where extiendeLista []           = []
          extiendeLista ((1:xs):yss) = xs : extiendeLista yss
          extiendeLista ((x:xs):yss) =
              extiendeLista ([y:x:xs | y <- divisores x] ++ yss)

-- (divisores x) es la lista decreciente de los divisores de x distintos
-- de x. Por ejemplo,
--    divisores 12  ==  [6,4,3,2,1]
divisores :: Int -> [Int]
divisores x = 
    [y | y <- [a,a-1..1], x `mod` y == 0]
    where a = x `div` 2

-- 2ª definición
-- =============

cadenasDivisores2 :: Int -> [[Int]]
cadenasDivisores2 = sort . aux
    where aux 1 = [[]]
          aux n = [xs ++ [n] | xs <- concatMap aux (divisores n)]

-- 3ª definición
-- =============

cadenasDivisores3 :: Int -> [[Int]]
cadenasDivisores3 = sort . map reverse . aux
    where aux 1 = [[]]
          aux n = map (n:) (concatMap aux (divisores3 n))

-- (divisores3 x) es la lista creciente de los divisores de x distintos
-- de x. Por ejemplo,
--    divisores3 12  ==  [1,2,3,4,6]
divisores3 :: Int -> [Int]
divisores3 x = 
    [y | y <- [1..a], x `mod` y == 0]
    where a = x `div` 2

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

nCadenasDivisores1 :: Int -> Int
nCadenasDivisores1 = length . cadenasDivisores

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

nCadenasDivisores2 :: Int -> Int
nCadenasDivisores2 1 = 1
nCadenasDivisores2 n = 
    sum [nCadenasDivisores2 x | x <- divisores n]

import Data.List (sort)

import Data.Numbers.Primes (isPrime)

-- 1ª definición

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

cadenasDivisores :: Int -> [[Int]]

cadenasDivisores n = sort (extiendeLista [[n]])

where extiendeLista [] = []

extiendeLista ((1:xs):yss) = xs : extiendeLista yss

extiendeLista ((x:xs):yss) =

extiendeLista ([y:x:xs | y <- divisores x] ++ yss)

-- (divisores x) es la lista decreciente de los divisores de x distintos

-- de x. Por ejemplo,

-- divisores 12 == [6,4,3,2,1]

divisores :: Int -> [Int]

divisores x =

[y | y <- [a,a-1..1], x `mod` y == 0]

where a = x `div` 2

-- 2ª definición

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

cadenasDivisores2 :: Int -> [[Int]]

cadenasDivisores2 = sort . aux

where aux 1 = [[]]

aux n = [xs ++ [n] | xs <- concatMap aux (divisores n)]

-- 3ª definición

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

cadenasDivisores3 :: Int -> [[Int]]

cadenasDivisores3 = sort . map reverse . aux

where aux 1 = [[]]

aux n = map (n:) (concatMap aux (divisores3 n))

-- (divisores3 x) es la lista creciente de los divisores de x distintos

-- de x. Por ejemplo,

-- divisores3 12 == [1,2,3,4,6]

divisores3 :: Int -> [Int]

divisores3 x =

[y | y <- [1..a], x `mod` y == 0]

where a = x `div` 2

-- 1ª definición de nCadenasDivisores

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

nCadenasDivisores1 :: Int -> Int

nCadenasDivisores1 = length . cadenasDivisores

-- 2ª definición de nCadenasDivisores

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

nCadenasDivisores2 :: Int -> Int

nCadenasDivisores2 1 = 1

nCadenasDivisores2 n =

sum [nCadenasDivisores2 x | x <- divisores n]

Sucesión fractal

PorJosé A. Alonso 13-mayo-202020-mayo-2020

La sucesión fractal

   0, 0, 1, 0, 2, 1, 3, 0, 4, 2, 5, 1, 6, 3, 7, 0, 8, 4, 9, 2, 
   10, 5, 11, 1, 12, 6, 13, 3, 14, 7, 15, ...

1 2	0, 0, 1, 0, 2, 1, 3, 0, 4, 2, 5, 1, 6, 3, 7, 0, 8, 4, 9, 2, 10, 5, 11, 1, 12, 6, 13, 3, 14, 7, 15, ...

está construida de la siguiente forma:

los términos pares forman la sucesión de los números naturales

     0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, ...

1	0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, ...

los términos impares forman la misma sucesión original

     0, 0, 1, 0, 2, 1, 3, 0, 4, 2, 5, 1, 6, 3, 7, ...

1	0, 0, 1, 0, 2, 1, 3, 0, 4, 2, 5, 1, 6, 3, 7, ...

Definir las funciones

   sucFractal     :: [Integer]
   sumaSucFractal :: Integer -> Integer

1 2	sucFractal :: [Integer] sumaSucFractal :: Integer -> Integer

tales que

sucFractal es la lista de los términos de la sucesión fractal. Por ejemplo,

     take 20 sucFractal   == [0,0,1,0,2,1,3,0,4,2,5,1,6,3,7,0,8,4,9,2]
     sucFractal !! 30     == 15
     sucFractal !! (10^7) == 5000000

take 20 sucFractal == [0,0,1,0,2,1,3,0,4,2,5,1,6,3,7,0,8,4,9,2]

sucFractal !! 30 == 15

sucFractal !! (10^7) == 5000000

(sumaSucFractal n) es la suma de los n primeros términos de la sucesión fractal. Por ejemplo,

     sumaSucFractal 10      == 13
     sumaSucFractal (10^5)  == 1666617368
     sumaSucFractal (10^10) == 16666666661668691669
     sumaSucFractal (10^15) == 166666666666666166673722792954
     sumaSucFractal (10^20) == 1666666666666666666616666684103392376198
     length (show (sumaSucFractal (10^15000))) == 30000
     sumaSucFractal (10^15000) `mod` (10^9)    == 455972157

sumaSucFractal 10 == 13

sumaSucFractal (10^5) == 1666617368

sumaSucFractal (10^10) == 16666666661668691669

sumaSucFractal (10^15) == 166666666666666166673722792954

sumaSucFractal (10^20) == 1666666666666666666616666684103392376198

length (show (sumaSucFractal (10^15000))) == 30000

sumaSucFractal (10^15000) `mod` (10^9) == 455972157

Soluciones

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

sucFractal1 :: [Integer]
sucFractal1 = 
  map termino [0..]

-- (termino n) es el término n de la secuencia anterior. Por ejemplo,
--   termino 0            ==  0
--   termino 1            ==  0
--   map termino [0..10]  ==  [0,0,1,0,2,1,3,0,4,2,5]
termino :: Integer -> Integer
termino 0 = 0
termino n 
  | even n    = n `div` 2
  | otherwise = termino (n `div` 2)

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

sucFractal2 :: [Integer]
sucFractal2 =
  0 : 0 : mezcla [1..] (tail sucFractal2)

-- (mezcla xs ys) es la lista obtenida intercalando las listas infinitas
-- xs e ys. Por ejemplo,
--    take 10 (mezcla [0,2..] [0,-2..])  ==  [0,0,2,-2,4,-4,6,-6,8,-8]
mezcla :: [Integer] -> [Integer] -> [Integer]
mezcla (x:xs) (y:ys) =
  x : y : mezcla xs ys

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

--    λ> sum (take (10^6) sucFractal1)
--    166666169612
--    (5.56 secs, 842,863,264 bytes)
--    λ> sum (take (10^6) sucFractal2)
--    166666169612
--    (1.81 secs, 306,262,616 bytes)

-- En lo que sigue usaremos la 2ª definición
sucFractal :: [Integer]
sucFractal = sucFractal2

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

sumaSucFractal1 :: Integer -> Integer
sumaSucFractal1 n =
  sum (map termino [0..n-1])

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

sumaSucFractal2 :: Integer -> Integer
sumaSucFractal2 n =
  sum (take (fromIntegral n) sucFractal)

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

sumaSucFractal3 :: Integer -> Integer
sumaSucFractal3 0 = 0
sumaSucFractal3 1 = 0
sumaSucFractal3 n
  | even n    = sumaN (n `div` 2) + sumaSucFractal3 (n `div` 2)
  | otherwise = sumaN ((n+1) `div` 2) + sumaSucFractal3 (n `div` 2)
  where sumaN n = (n*(n-1)) `div` 2

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

--    λ> sumaSucFractal1 (10^6)
--    166666169612
--    (5.25 secs, 810,622,504 bytes)
--    λ> sumaSucFractal2 (10^6)
--    166666169612
--    (1.72 secs, 286,444,048 bytes)
--    λ> sumaSucFractal3 (10^6)
--    166666169612
--    (0.01 secs, 0 bytes)
--    
--    λ> sumaSucFractal2 (10^7)
--    16666661685034
--    (17.49 secs, 3,021,580,920 bytes)
--    λ> sumaSucFractal3 (10^7)
--    16666661685034
--    (0.01 secs, 0 bytes)

-- 1ª definición de sucFractal

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

sucFractal1 :: [Integer]

sucFractal1 =

map termino [0..]

-- (termino n) es el término n de la secuencia anterior. Por ejemplo,

-- termino 0 == 0

-- termino 1 == 0

-- map termino [0..10] == [0,0,1,0,2,1,3,0,4,2,5]

termino :: Integer -> Integer

termino 0 = 0

termino n

| even n = n `div` 2

| otherwise = termino (n `div` 2)

-- 2ª definición de sucFractal

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

sucFractal2 :: [Integer]

sucFractal2 =

0 : 0 : mezcla [1..] (tail sucFractal2)

-- (mezcla xs ys) es la lista obtenida intercalando las listas infinitas

-- xs e ys. Por ejemplo,

-- take 10 (mezcla [0,2..] [0,-2..]) == [0,0,2,-2,4,-4,6,-6,8,-8]

mezcla :: [Integer] -> [Integer] -> [Integer]

mezcla (x:xs) (y:ys) =

x : y : mezcla xs ys

-- Comparación de eficiencia de definiciones de sucFractal

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

-- λ> sum (take (10^6) sucFractal1)

-- 166666169612

-- (5.56 secs, 842,863,264 bytes)

-- λ> sum (take (10^6) sucFractal2)

-- 166666169612

-- (1.81 secs, 306,262,616 bytes)

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

sucFractal :: [Integer]

sucFractal = sucFractal2

-- 1ª definición de sumaSucFractal

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

sumaSucFractal1 :: Integer -> Integer

sumaSucFractal1 n =

sum (map termino [0..n-1])

-- 2ª definición de sumaSucFractal

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

sumaSucFractal2 :: Integer -> Integer

sumaSucFractal2 n =

sum (take (fromIntegral n) sucFractal)

-- 3ª definición de sumaSucFractal

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

sumaSucFractal3 :: Integer -> Integer

sumaSucFractal3 0 = 0

sumaSucFractal3 1 = 0

sumaSucFractal3 n

| even n = sumaN (n `div` 2) + sumaSucFractal3 (n `div` 2)

| otherwise = sumaN ((n+1) `div` 2) + sumaSucFractal3 (n `div` 2)

where sumaN n = (n*(n-1)) `div` 2

-- Comparación de eficiencia de definiciones de sumaSucFractal

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

-- λ> sumaSucFractal1 (10^6)

-- 166666169612

-- (5.25 secs, 810,622,504 bytes)

-- λ> sumaSucFractal2 (10^6)

-- 166666169612

-- (1.72 secs, 286,444,048 bytes)

-- λ> sumaSucFractal3 (10^6)

-- 166666169612

-- (0.01 secs, 0 bytes)

-- λ> sumaSucFractal2 (10^7)

-- 16666661685034

-- (17.49 secs, 3,021,580,920 bytes)

-- λ> sumaSucFractal3 (10^7)

-- 16666661685034

-- (0.01 secs, 0 bytes)

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Entradas recientes

Buscar

Correo electrónico