Orden superior – Página 2

Emparejamiento binario

PorJosé A. Alonso 21-marzo-202228-marzo-2022

Definir la función

   zipBinario :: [a -> b -> c] -> [a] -> [b] -> [c]

1	zipBinario :: [a -> b -> c] -> [a] -> [b] -> [c]

tal que (zipBinario fs xs ys) es la lista obtenida aplicando cada una de las operaciones binarias de fs a los correspondientes elementos de xs e ys. Por ejemplo,

   zipBinario [(+), (*), (*)] [2,2,2] [4,4,4]    == [6,8,8]
   zipBinario [(+)] [2,2,2] [4,4,4]              == [6]
   zipBinario [(<), (==), (==)] "coloca" "lobo"  == [True,True,False]

zipBinario [(+), (*), (*)] [2,2,2] [4,4,4] == [6,8,8]

zipBinario [(+)] [2,2,2] [4,4,4] == [6]

zipBinario [(<), (==), (==)] "coloca" "lobo" == [True,True,False]

Soluciones

import Test.QuickCheck
import Test.QuickCheck.HigherOrder
import Test.Hspec

-- 1ª solución
zipBinario1 :: [a -> b -> c] -> [a] -> [b] -> [c]
zipBinario1 (f:fs) (x:xs) (y:ys) = f x y : zipBinario1 fs xs ys
zipBinario1 _ _ _                = []

-- 2ª solución
zipBinario2 :: [a -> b -> c] -> [a] -> [b] -> [c]
zipBinario2 fs xs ys = [f x y | (f,(x,y)) <- zip fs (zip xs ys)]

-- 3ª solución
zipBinario3 :: [a -> b -> c] -> [a] -> [b] -> [c]
zipBinario3 fs xs ys = [f x y | (f,x,y) <- zip3 fs xs ys]

-- 4ª solución
zipBinario4 :: [a -> b -> c] -> [a] -> [b] -> [c]
zipBinario4 = zipWith3 id

-- Verificación
-- ============

especificacion :: ([Int -> Int -> Int] -> [Int] -> [Int] -> [Int]) -> Spec
especificacion zipBinario = do
  it "e1" $ zipBinario [(+), (*), (*)] [2,2,2] [4,4,4]    `shouldBe` [6,8,8]
  it "e2" $ zipBinario [(+)] [2,2,2] [4,4,4]              `shouldBe` [6]

verifica :: IO ()
verifica = hspec $ do
  describe "zipBinario1" $ especificacion zipBinario1
  describe "zipBinario2" $ especificacion zipBinario2
  describe "zipBinario3" $ especificacion zipBinario3
  describe "zipBinario4" $ especificacion zipBinario4

-- La verificación es
--    λ> verifica
--
--    zipBinario1
--      e1
--      e2
--    zipBinario2
--      e1
--      e2
--    zipBinario3
--      e1
--      e2
--    zipBinario4
--      e1
--      e2
--
--    Finished in 0.0016 seconds
--    8 examples, 0 failures

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


-- La propiedad es
prop_zipBinario :: [Bool -> Bool -> Bool] -> [Bool] -> [Bool] -> Bool
prop_zipBinario fs xs ys =
  all (== zipBinario1 fs xs ys)
      [g fs xs ys | g <- [zipBinario2,
                          zipBinario3,
                          zipBinario4]]

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

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

-- La comparación es
--    λ> maximum (zipBinario1 (cycle [(+), (*)]) [1..] [1..2*10^6])
--    4000000000000
--    (2.13 secs, 965,392,072 bytes)
--    λ> maximum (zipBinario2 (cycle [(+), (*)]) [1..] [1..2*10^6])
--    4000000000000
--    (1.86 secs, 1,109,392,176 bytes)
--    λ> maximum (zipBinario3 (cycle [(+), (*)]) [1..] [1..2*10^6])
--    4000000000000
--    (1.93 secs, 981,392,128 bytes)
--    λ> maximum (zipBinario4 (cycle [(+), (*)]) [1..] [1..2*10^6])
--    4000000000000
--    (1.07 secs, 773,392,040 bytes)

import Test.QuickCheck

import Test.QuickCheck.HigherOrder

import Test.Hspec

-- 1ª solución

zipBinario1 :: [a -> b -> c] -> [a] -> [b] -> [c]

zipBinario1 (f:fs) (x:xs) (y:ys) = f x y : zipBinario1 fs xs ys

zipBinario1 _ _ _ = []

-- 2ª solución

zipBinario2 :: [a -> b -> c] -> [a] -> [b] -> [c]

zipBinario2 fs xs ys = [f x y | (f,(x,y)) <- zip fs (zip xs ys)]

-- 3ª solución

zipBinario3 :: [a -> b -> c] -> [a] -> [b] -> [c]

zipBinario3 fs xs ys = [f x y | (f,x,y) <- zip3 fs xs ys]

-- 4ª solución

zipBinario4 :: [a -> b -> c] -> [a] -> [b] -> [c]

zipBinario4 = zipWith3 id

-- Verificación

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

especificacion :: ([Int -> Int -> Int] -> [Int] -> [Int] -> [Int]) -> Spec

especificacion zipBinario = do

it "e1" $ zipBinario [(+), (*), (*)] [2,2,2] [4,4,4] `shouldBe` [6,8,8]

it "e2" $ zipBinario [(+)] [2,2,2] [4,4,4] `shouldBe` [6]

verifica :: IO ()

verifica = hspec $ do

describe "zipBinario1" $ especificacion zipBinario1

describe "zipBinario2" $ especificacion zipBinario2

describe "zipBinario3" $ especificacion zipBinario3

describe "zipBinario4" $ especificacion zipBinario4

-- La verificación es

-- λ> verifica

-- zipBinario1

-- e1

-- e2

-- zipBinario2

-- e1

-- e2

-- zipBinario3

-- e1

-- e2

-- zipBinario4

-- e1

-- e2

-- Finished in 0.0016 seconds

-- 8 examples, 0 failures

-- Comprobación de equivalencia

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

-- La propiedad es

prop_zipBinario :: [Bool -> Bool -> Bool] -> [Bool] -> [Bool] -> Bool

prop_zipBinario fs xs ys =

all (== zipBinario1 fs xs ys)

[g fs xs ys | g <- [zipBinario2,

zipBinario3,

zipBinario4]]

-- La comprobación es

-- λ> quickCheck' prop_zipBinario

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> maximum (zipBinario1 (cycle [(+), (*)]) [1..] [1..2*10^6])

-- 4000000000000

-- (2.13 secs, 965,392,072 bytes)

-- λ> maximum (zipBinario2 (cycle [(+), (*)]) [1..] [1..2*10^6])

-- 4000000000000

-- (1.86 secs, 1,109,392,176 bytes)

-- λ> maximum (zipBinario3 (cycle [(+), (*)]) [1..] [1..2*10^6])

-- 4000000000000

-- (1.93 secs, 981,392,128 bytes)

-- λ> maximum (zipBinario4 (cycle [(+), (*)]) [1..] [1..2*10^6])

-- 4000000000000

-- (1.07 secs, 773,392,040 bytes)

El código se encuentra en GitHub.

La elaboración de las soluciones se describe en el siguiente vídeo

Nuevas soluciones

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

Ordenación de estructuras

PorJosé A. Alonso 18-marzo-202225-marzo-2022

Las notas de los dos primeros exámenes se pueden representar mediante el siguiente tipo de dato

   data Notas = Notas String Int Int
     deriving (Read, Show, Eq)

1 2	data Notas = Notas String Int Int deriving (Read, Show, Eq)

Por ejemplo, (Notas «Juan» 6 5) representa las notas de un alumno cuyo nombre es Juan, la nota del primer examen es 6 y la del segundo es 5.

Definir la función

   ordenadas :: [Notas] -> [Notas]

1	ordenadas :: [Notas] -> [Notas]

tal que (ordenadas ns) es la lista de las notas ns ordenadas considerando primero la nota del examen 2, a continuación la del examen 1 y finalmente el nombre. Por ejemplo,

   λ> ordenadas [Notas "Juan" 6 5, Notas "Luis" 3 7]
   [Notas "Juan" 6 5,Notas "Luis" 3 7]
   λ> ordenadas [Notas "Juan" 6 5, Notas "Luis" 3 4]
   [Notas "Luis" 3 4,Notas "Juan" 6 5]
   λ> ordenadas [Notas "Juan" 6 5, Notas "Luis" 7 4]
   [Notas "Luis" 7 4,Notas "Juan" 6 5]
   λ> ordenadas [Notas "Juan" 6 4, Notas "Luis" 7 4]
   [Notas "Juan" 6 4,Notas "Luis" 7 4]
   λ> ordenadas [Notas "Juan" 6 4, Notas "Luis" 5 4]
   [Notas "Luis" 5 4,Notas "Juan" 6 4]
   λ> ordenadas [Notas "Juan" 5 4, Notas "Luis" 5 4]
   [Notas "Juan" 5 4,Notas "Luis" 5 4]
   λ> ordenadas [Notas "Juan" 5 4, Notas "Eva" 5 4]
   [Notas "Eva" 5 4,Notas "Juan" 5 4]

λ> ordenadas [Notas "Juan" 6 5, Notas "Luis" 3 7]

[Notas "Juan" 6 5,Notas "Luis" 3 7]

λ> ordenadas [Notas "Juan" 6 5, Notas "Luis" 3 4]

[Notas "Luis" 3 4,Notas "Juan" 6 5]

λ> ordenadas [Notas "Juan" 6 5, Notas "Luis" 7 4]

[Notas "Luis" 7 4,Notas "Juan" 6 5]

λ> ordenadas [Notas "Juan" 6 4, Notas "Luis" 7 4]

[Notas "Juan" 6 4,Notas "Luis" 7 4]

λ> ordenadas [Notas "Juan" 6 4, Notas "Luis" 5 4]

[Notas "Luis" 5 4,Notas "Juan" 6 4]

λ> ordenadas [Notas "Juan" 5 4, Notas "Luis" 5 4]

[Notas "Juan" 5 4,Notas "Luis" 5 4]

λ> ordenadas [Notas "Juan" 5 4, Notas "Eva" 5 4]

[Notas "Eva" 5 4,Notas "Juan" 5 4]

Soluciones

import Data.List (sort, sortBy)
import Test.QuickCheck

data Notas = Notas String Int Int
  deriving (Read, Show, Eq)

-- 1ª solución
ordenadas1 :: [Notas] -> [Notas]
ordenadas1 ns =
  [Notas n x y | (y,x,n) <- sort [(y1,x1,n1) | (Notas n1 x1 y1) <- ns]]

-- 2ª solución
ordenadas2 :: [Notas] -> [Notas]
ordenadas2 ns =
  map (\(y,x,n) -> Notas n x y) (sort [(y1,x1,n1) | (Notas n1 x1 y1) <- ns])

-- 3ª solución
ordenadas3 :: [Notas] -> [Notas]
ordenadas3 ns = sortBy (\(Notas n1 x1 y1) (Notas n2 x2 y2) ->
                          compare (y1,x1,n1) (y2,x2,n2))
                       ns

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

instance Ord Notas where
  Notas n1 x1 y1 <= Notas n2 x2 y2 = (y1,x1,n1) <= (y2,x2,n2)

ordenadas4 :: [Notas] -> [Notas]
ordenadas4 = sort

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

-- notasArbitraria es un generador aleatorio de notas. Por ejemplo,
--    λ> sample notasArbitraria
--    Notas "achjkqruvxy" 3 3
--    Notas "abfgikmptuvy" 10 10
--    Notas "degjmptvwx" 7 9
--    Notas "cdefghjmnoqrsuw" 0 9
--    Notas "bcdfikmstuxz" 1 8
--    Notas "abcdhkopqsvwx" 10 7
--    Notas "abghiklnoqstvwx" 0 0
--    Notas "abfghklmnoptuvx" 4 9
--    Notas "bdehjkmpqsxyz" 0 4
--    Notas "afghijmopsvwz" 3 7
--    Notas "bdefghjklnoqx" 2 3
notasArbitraria :: Gen Notas
notasArbitraria = do
  n <- sublistOf ['a'..'z']
  x <- chooseInt (0, 10)
  y <- chooseInt (0, 10)
  return (Notas n x y)

-- Notas es una subclase de Arbitrary
instance Arbitrary Notas where
  arbitrary = notasArbitraria

-- La propiedad es
prop_ordenadas :: [Notas] -> Bool
prop_ordenadas ns =
  all (== ordenadas1 ns)
      [f ns | f <- [ordenadas2,
                    ordenadas3,
                    ordenadas4]]

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

import Data.List (sort, sortBy)

import Test.QuickCheck

data Notas = Notas String Int Int

deriving (Read, Show, Eq)

-- 1ª solución

ordenadas1 :: [Notas] -> [Notas]

ordenadas1 ns =

[Notas n x y | (y,x,n) <- sort [(y1,x1,n1) | (Notas n1 x1 y1) <- ns]]

-- 2ª solución

ordenadas2 :: [Notas] -> [Notas]

ordenadas2 ns =

map (\(y,x,n) -> Notas n x y) (sort [(y1,x1,n1) | (Notas n1 x1 y1) <- ns])

-- 3ª solución

ordenadas3 :: [Notas] -> [Notas]

ordenadas3 ns = sortBy (\(Notas n1 x1 y1) (Notas n2 x2 y2) ->

compare (y1,x1,n1) (y2,x2,n2))

-- 4ª solución

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

instance Ord Notas where

Notas n1 x1 y1 <= Notas n2 x2 y2 = (y1,x1,n1) <= (y2,x2,n2)

ordenadas4 :: [Notas] -> [Notas]

ordenadas4 = sort

-- Comprobación de equivalencia

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

-- notasArbitraria es un generador aleatorio de notas. Por ejemplo,

-- λ> sample notasArbitraria

-- Notas "achjkqruvxy" 3 3

-- Notas "abfgikmptuvy" 10 10

-- Notas "degjmptvwx" 7 9

-- Notas "cdefghjmnoqrsuw" 0 9

-- Notas "bcdfikmstuxz" 1 8

-- Notas "abcdhkopqsvwx" 10 7

-- Notas "abghiklnoqstvwx" 0 0

-- Notas "abfghklmnoptuvx" 4 9

-- Notas "bdehjkmpqsxyz" 0 4

-- Notas "afghijmopsvwz" 3 7

-- Notas "bdefghjklnoqx" 2 3

notasArbitraria :: Gen Notas

notasArbitraria = do

n <- sublistOf ['a'..'z']

x <- chooseInt (0, 10)

y <- chooseInt (0, 10)

return (Notas n x y)

-- Notas es una subclase de Arbitrary

instance Arbitrary Notas where

arbitrary = notasArbitraria

-- La propiedad es

prop_ordenadas :: [Notas] -> Bool

prop_ordenadas ns =

all (== ordenadas1 ns)

[f ns | f <- [ordenadas2,

ordenadas3,

ordenadas4]]

-- La comprobación es

-- λ> quickCheck prop_ordenadas

-- +++ OK, passed 100 tests.

El código se encuentra en GitHub.

La elaboración de las soluciones se muestra en el siguiente vídeo

Numeración de las ternas de números naturales

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

Las ternas de números naturales se pueden ordenar como sigue

   (0,0,0),
   (0,0,1),(0,1,0),(1,0,0),
   (0,0,2),(0,1,1),(0,2,0),(1,0,1),(1,1,0),(2,0,0),
   (0,0,3),(0,1,2),(0,2,1),(0,3,0),(1,0,2),(1,1,1),(1,2,0),(2,0,1),...
   ...

(0,0,0),

(0,0,1),(0,1,0),(1,0,0),

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

(0,0,3),(0,1,2),(0,2,1),(0,3,0),(1,0,2),(1,1,1),(1,2,0),(2,0,1),...

...

Definir la función

   posicion :: (Int,Int,Int) -> Int

1	posicion :: (Int,Int,Int) -> Int

tal que (posicion (x,y,z)) es la posición de la terna de números naturales (x,y,z) en la ordenación anterior. Por ejemplo,

   posicion (0,1,0)  ==  2
   posicion (0,0,2)  ==  4
   posicion (0,1,1)  ==  5

posicion (0,1,0) == 2

posicion (0,0,2) == 4

posicion (0,1,1) == 5

Comprobar con QuickCheck que

la posición de (x,0,0) es x(x²+6x+11)/6
la posición de (0,y,0) es y(y²+3y+ 8)/6
la posición de (0,0,z) es z(z²+3z+ 2)/6
la posición de (x,x,x) es x(9x²+14x+7)/2

Soluciones

import Data.List (elemIndex)
import Data.Maybe (fromJust)
import Test.QuickCheck

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

posicion1 :: (Int,Int,Int) -> Int
posicion1 t = aux 0 ternas
  where aux n (t':ts) | t' == t   = n
                      | otherwise = aux (n+1) ts

-- ternas es la lista ordenada de las ternas de números naturales. Por ejemplo,
--    λ> take 9 ternas
--    [(0,0,0),(0,0,1),(0,1,0),(1,0,0),(0,0,2),(0,1,1),(0,2,0),(1,0,1),(1,1,0)]
ternas :: [(Int,Int,Int)]
ternas = [(x,y,n-x-y) | n <- [0..], x <- [0..n], y <- [0..n-x]]

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

posicion2 :: (Int,Int,Int) -> Int
posicion2 t =
  head [n | (n,t') <- zip [0..] ternas, t' == t]

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

posicion3 :: (Int,Int,Int) -> Int
posicion3 t = indice t ternas

-- (indice x ys) es el índice de x en ys. Por ejemplo,
--    indice 5 [0..]  ==  5
indice :: Eq a => a -> [a] -> Int
indice x ys = length (takeWhile (/= x) ys)

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

posicion4 :: (Int,Int,Int) -> Int
posicion4 t = fromJust (elemIndex t ternas)

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

posicion5 :: (Int,Int,Int) -> Int
posicion5 = fromJust . (`elemIndex` ternas)

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

-- La propiedad es
prop_posicion_equiv :: NonNegative Int
                    -> NonNegative Int
                    -> NonNegative Int
                    -> Bool
prop_posicion_equiv (NonNegative x) (NonNegative y) (NonNegative z) =
  all (== posicion1 (x,y,z))
      [f (x,y,z) | f <- [ posicion2
                        , posicion3
                        , posicion4
                        , posicion5 ]]

-- La comprobación es
--    λ> quickCheckWith (stdArgs {maxSize=20}) prop_posicion_equiv
--    +++ OK, passed 100 tests.

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

-- La comparación es
--    λ> posicion1 (147,46,116)
--    5000000
--    (5.84 secs, 2,621,428,184 bytes)
--    λ> posicion2 (147,46,116)
--    5000000
--    (3.63 secs, 2,173,230,200 bytes)
--    λ> posicion3 (147,46,116)
--    5000000
--    (2.48 secs, 1,453,229,880 bytes)
--    λ> posicion4 (147,46,116)
--    5000000
--    (1.91 secs, 1,173,229,840 bytes)
--    λ> posicion5 (147,46,116)
--    5000000
--    (1.94 secs, 1,173,229,960 bytes)

-- En lo que sigue, usaremos la 5ª definición
posicion :: (Int,Int,Int) -> Int
posicion = posicion5

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

-- La 1ª propiedad es
prop_posicion1 :: NonNegative Int -> Bool
prop_posicion1 (NonNegative x) =
  posicion (x,0,0) == x * (x^2 + 6*x + 11) `div` 6

-- Su comprobación es
--    λ> quickCheckWith (stdArgs {maxSize=20}) prop_posicion1
--    +++ OK, passed 100 tests.

-- La 2ª propiedad es
prop_posicion2 :: NonNegative Int -> Bool
prop_posicion2 (NonNegative y) =
  posicion (0,y,0) == y * (y^2 + 3*y + 8) `div` 6

-- Su comprobación es
--    λ> quickCheckWith (stdArgs {maxSize=20}) prop_posicion2
--    +++ OK, passed 100 tests.

-- La 3ª propiedad es
prop_posicion3 :: NonNegative Int -> Bool
prop_posicion3 (NonNegative z) =
  posicion (0,0,z) == z * (z^2 + 3*z + 2) `div` 6

-- Su comprobación es
--    λ> quickCheckWith (stdArgs {maxSize=20}) prop_posicion3
--    +++ OK, passed 100 tests.

-- La 4ª propiedad es
prop_posicion4 :: NonNegative Int -> Bool
prop_posicion4 (NonNegative x) =
  posicion (x,x,x) == x * (9 * x^2 + 14 * x + 7) `div` 2

-- Su comprobación es
--    λ> quickCheckWith (stdArgs {maxSize=20}) prop_posicion4
--    +++ OK, passed 100 tests.

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

import Data.List (elemIndex)

import Data.Maybe (fromJust)

import Test.QuickCheck

-- 1ª solución

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

posicion1 :: (Int,Int,Int) -> Int

posicion1 t = aux 0 ternas

where aux n (t':ts) | t' == t = n

| otherwise = aux (n+1) ts

-- ternas es la lista ordenada de las ternas de números naturales. Por ejemplo,

-- λ> take 9 ternas

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

ternas :: [(Int,Int,Int)]

ternas = [(x,y,n-x-y) | n <- [0..], x <- [0..n], y <- [0..n-x]]

-- 2ª solución

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

posicion2 :: (Int,Int,Int) -> Int

posicion2 t =

head [n | (n,t') <- zip [0..] ternas, t' == t]

-- 3ª solución

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

posicion3 :: (Int,Int,Int) -> Int

posicion3 t = indice t ternas

-- (indice x ys) es el índice de x en ys. Por ejemplo,

-- indice 5 [0..] == 5

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

indice x ys = length (takeWhile (/= x) ys)

-- 4ª solución

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

posicion4 :: (Int,Int,Int) -> Int

posicion4 t = fromJust (elemIndex t ternas)

-- 5ª solución

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

posicion5 :: (Int,Int,Int) -> Int

posicion5 = fromJust . (`elemIndex` ternas)

-- Equivalencia

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

-- La propiedad es

prop_posicion_equiv :: NonNegative Int

-> NonNegative Int

-> Bool

prop_posicion_equiv (NonNegative x) (NonNegative y) (NonNegative z) =

all (== posicion1 (x,y,z))

[f (x,y,z) | f <- [ posicion2

, posicion3

, posicion4

, posicion5 ]]

-- La comprobación es

-- λ> quickCheckWith (stdArgs {maxSize=20}) prop_posicion_equiv

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> posicion1 (147,46,116)

-- 5000000

-- (5.84 secs, 2,621,428,184 bytes)

-- λ> posicion2 (147,46,116)

-- 5000000

-- (3.63 secs, 2,173,230,200 bytes)

-- λ> posicion3 (147,46,116)

-- 5000000

-- (2.48 secs, 1,453,229,880 bytes)

-- λ> posicion4 (147,46,116)

-- 5000000

-- (1.91 secs, 1,173,229,840 bytes)

-- λ> posicion5 (147,46,116)

-- 5000000

-- (1.94 secs, 1,173,229,960 bytes)

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

posicion :: (Int,Int,Int) -> Int

posicion = posicion5

-- Propiedades

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

-- La 1ª propiedad es

prop_posicion1 :: NonNegative Int -> Bool

prop_posicion1 (NonNegative x) =

posicion (x,0,0) == x * (x^2 + 6*x + 11) `div` 6

-- Su comprobación es

-- λ> quickCheckWith (stdArgs {maxSize=20}) prop_posicion1

-- +++ OK, passed 100 tests.

-- La 2ª propiedad es

prop_posicion2 :: NonNegative Int -> Bool

prop_posicion2 (NonNegative y) =

posicion (0,y,0) == y * (y^2 + 3*y + 8) `div` 6

-- Su comprobación es

-- λ> quickCheckWith (stdArgs {maxSize=20}) prop_posicion2

-- +++ OK, passed 100 tests.

-- La 3ª propiedad es

prop_posicion3 :: NonNegative Int -> Bool

prop_posicion3 (NonNegative z) =

posicion (0,0,z) == z * (z^2 + 3*z + 2) `div` 6

-- Su comprobación es

-- λ> quickCheckWith (stdArgs {maxSize=20}) prop_posicion3

-- +++ OK, passed 100 tests.

-- La 4ª propiedad es

prop_posicion4 :: NonNegative Int -> Bool

prop_posicion4 (NonNegative x) =

posicion (x,x,x) == x * (9 * x^2 + 14 * x + 7) `div` 2

-- Su comprobación es

-- λ> quickCheckWith (stdArgs {maxSize=20}) prop_posicion4

-- +++ OK, passed 100 tests.

El código se encuentra en GitHub.

La elaboración de las soluciones se muestra en el siguiente vídeo:

Alfabeto comenzando en un carácter

PorJosé A. Alonso 16-marzo-202223-marzo-2022

Definir la función

   alfabetoDesde :: Char -> String

1	alfabetoDesde :: Char -> String

tal que (alfabetoDesde c) es el alfabeto, en minúscula, comenzando en el carácter c, si c es una letra minúscula y comenzando en ‘a’, en caso contrario. Por ejemplo,

   alfabetoDesde 'e'  ==  "efghijklmnopqrstuvwxyzabcd"
   alfabetoDesde 'a'  ==  "abcdefghijklmnopqrstuvwxyz"
   alfabetoDesde '7'  ==  "abcdefghijklmnopqrstuvwxyz"
   alfabetoDesde '{'  ==  "abcdefghijklmnopqrstuvwxyz"
   alfabetoDesde 'B'  ==  "abcdefghijklmnopqrstuvwxyz"

alfabetoDesde 'e' == "efghijklmnopqrstuvwxyzabcd"

alfabetoDesde 'a' == "abcdefghijklmnopqrstuvwxyz"

alfabetoDesde '7' == "abcdefghijklmnopqrstuvwxyz"

alfabetoDesde '{' == "abcdefghijklmnopqrstuvwxyz"

alfabetoDesde 'B' == "abcdefghijklmnopqrstuvwxyz"

Soluciones

import Data.Char (isLower, isAscii)
import Test.QuickCheck

-- 1ª solución
alfabetoDesde1 :: Char -> String
alfabetoDesde1 c =
  dropWhile (<c) ['a'..'z'] ++ takeWhile (<c) ['a'..'z']

-- 2ª solución
alfabetoDesde2 :: Char -> String
alfabetoDesde2 c = ys ++ xs
  where (xs,ys) = span (<c) ['a'..'z']

-- 3ª solución
alfabetoDesde3 :: Char -> String
alfabetoDesde3 c = ys ++ xs
  where (xs,ys) = break (==c) ['a'..'z']

-- 4ª solución
alfabetoDesde4 :: Char -> String
alfabetoDesde4 c
  | 'a' <= c && c <= 'z' = [c..'z'] ++ ['a'..pred c]
  | otherwise            = ['a'..'z']

-- 5ª solución
alfabetoDesde5 :: Char -> String
alfabetoDesde5 c
  | isLower c = [c..'z'] ++ ['a'..pred c]
  | otherwise = ['a'..'z']

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

-- La propiedad es
prop_alfabetoDesde :: Property
prop_alfabetoDesde =
  forAll (arbitrary `suchThat` isAscii) $ \c ->
  all (== alfabetoDesde1 c)
      [f c | f <- [alfabetoDesde2,
                   alfabetoDesde3,
                   alfabetoDesde4,
                   alfabetoDesde5]]


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

import Data.Char (isLower, isAscii)

import Test.QuickCheck

-- 1ª solución

alfabetoDesde1 :: Char -> String

alfabetoDesde1 c =

dropWhile (<c) ['a'..'z'] ++ takeWhile (<c) ['a'..'z']

-- 2ª solución

alfabetoDesde2 :: Char -> String

alfabetoDesde2 c = ys ++ xs

where (xs,ys) = span (<c) ['a'..'z']

-- 3ª solución

alfabetoDesde3 :: Char -> String

alfabetoDesde3 c = ys ++ xs

where (xs,ys) = break (==c) ['a'..'z']

-- 4ª solución

alfabetoDesde4 :: Char -> String

alfabetoDesde4 c

| 'a' <= c && c <= 'z' = [c..'z'] ++ ['a'..pred c]

| otherwise = ['a'..'z']

-- 5ª solución

alfabetoDesde5 :: Char -> String

alfabetoDesde5 c

| isLower c = [c..'z'] ++ ['a'..pred c]

| otherwise = ['a'..'z']

-- Comprobación de equivalencia

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

-- La propiedad es

prop_alfabetoDesde :: Property

prop_alfabetoDesde =

forAll (arbitrary `suchThat` isAscii) $ \c ->

all (== alfabetoDesde1 c)

[f c | f <- [alfabetoDesde2,

alfabetoDesde3,

alfabetoDesde4,

alfabetoDesde5]]

-- La comprobación es

-- λ> quickCheck prop_alfabetoDesde

-- +++ OK, passed 100 tests.

El código se encuentra en GitHub.

La elaboración de las soluciones se muestra en el siguiente vídeo

Ramas de un árbol

PorJosé A. Alonso 15-marzo-202226-marzo-2022

Los árboles se pueden representar mediante el siguiente tipo de datos

   data Arbol a = N a [Arbol a]
     deriving Show

1 2	data Arbol a = N a [Arbol a] deriving Show

Por ejemplo, los árboles

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

1 3

/ \ /|\

2 3 / | \

| 5 4 7

4 | /\

6 2 1

se representan por

   ej1, ej2 :: Arbol Int
   ej1 = N 1 [N 2 [],N 3 [N 4 []]]
   ej2 = N 3 [N 5 [N 6 []], N 4 [], N 7 [N 2 [], N 1 []]

ej1, ej2 :: Arbol Int

ej1 = N 1 [N 2 [],N 3 [N 4 []]]

ej2 = N 3 [N 5 [N 6 []], N 4 [], N 7 [N 2 [], N 1 []]

Definir la función

   ramas :: Arbol b -> [[b]]

1	ramas :: Arbol b -> [[b]]

tal que (ramas a) es la lista de las ramas del árbol a. Por ejemplo,

   ramas ej1  ==  [[1,2],[1,3,4]]
   ramas ej2  ==  [[3,5,6],[3,4],[3,7,2],[3,7,1]]

1 2	ramas ej1 == [[1,2],[1,3,4]] ramas ej2 == [[3,5,6],[3,4],[3,7,2],[3,7,1]]

Soluciones

import Test.QuickCheck

data Arbol a = N a [Arbol a]
  deriving Show

ej1, ej2 :: Arbol Int
ej1 = N 1 [N 2 [],N 3 [N 4 []]]
ej2 = N 3 [N 5 [N 6 []], N 4 [], N 7 [N 2 [], N 1 []]]

-- 1ª solución
ramas1 :: Arbol b -> [[b]]
ramas1 (N x []) = [[x]]
ramas1 (N x as) = [x : xs | a <- as, xs <- ramas1 a]

-- 2ª solución
ramas2 :: Arbol b -> [[b]]
ramas2 (N x []) = [[x]]
ramas2 (N x as) = concat (map (map (x:)) (map ramas2 as))

-- 3ª solución
ramas3 :: Arbol b -> [[b]]
ramas3 (N x []) = [[x]]
ramas3 (N x as) = concat (map (map (x:) . ramas3) as)

-- 4ª solución
ramas4 :: Arbol b -> [[b]]
ramas4 (N x []) = [[x]]
ramas4 (N x as) = concatMap (map (x:) . ramas4) as

-- 5ª solución
ramas5 :: Arbol a -> [[a]]
ramas5 (N x []) = [[x]]
ramas5 (N x xs) = map ramas5 xs >>= map (x:)

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

-- (arbolArbitrario n) es un árbol aleatorio de orden n. Por ejemplo,
--    λ> sample (arbolArbitrario 4 :: Gen (Arbol Int))
--    N 0 [N 0 []]
--    N 1 [N 1 [N (-2) [N (-1) [N (-1) [N (-1) [N 1 []]]]]],N (-1) [N 2 []]]
--    N 1 [N (-2) [],N 0 [N (-4) [N (-2) []]]]
--    N (-4) [N 1 [],N 0 [N 6 [N (-4) []],N 2 [N 3 []]]]
--    N (-7) [N (-7) [N (-3) []]]
--    N (-2) [N (-8) []]
--    N (-3) [N 3 [N 2 []]]
--    N (-12) [N 5 [],N 0 []]
--    N 14 [N 13 [N (-12) []],N 11 [],N 8 [N (-13) []]]
--    N (-12) [N (-6) [N 16 [N (-14) [N (-1) []]]]]
--    N (-5) []
arbolArbitrario :: Arbitrary a => Int -> Gen (Arbol a)
arbolArbitrario n = do
  x  <- arbitrary
  ms <- sublistOf [0 .. n `div` 2]
  as <- mapM arbolArbitrario ms
  return (N x as)

-- Arbol es una subclase de Arbitraria
instance Arbitrary a => Arbitrary (Arbol a) where
  arbitrary = sized arbolArbitrario

-- La propiedad es
prop_arbol :: Arbol Int -> Bool
prop_arbol a =
  all (== ramas1 a)
      [ramas2 a,
       ramas3 a,
       ramas4 a,
       ramas5 a]

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

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

-- La comparación es
--    λ> ej600 <- generate (arbolArbitrario 600 :: Gen (Arbol Int))
--    λ> length (ramas1 ej600)
--    1262732
--    (1.92 secs, 1,700,238,488 bytes)
--    λ> length (ramas2 ej600)
--    1262732
--    (1.94 secs, 2,549,877,280 bytes)
--    λ> length (ramas3 ej600)
--    1262732
--    (1.99 secs, 2,446,508,472 bytes)
--    λ> length (ramas4 ej600)
--    1262732
--    (1.67 secs, 2,090,469,104 bytes)
--    λ> length (ramas5 ej600)
--    1262732
--    (1.66 secs, 2,112,198,232 bytes)

import Test.QuickCheck

data Arbol a = N a [Arbol a]

deriving Show

ej1, ej2 :: Arbol Int

ej1 = N 1 [N 2 [],N 3 [N 4 []]]

ej2 = N 3 [N 5 [N 6 []], N 4 [], N 7 [N 2 [], N 1 []]]

-- 1ª solución

ramas1 :: Arbol b -> [[b]]

ramas1 (N x []) = [[x]]

ramas1 (N x as) = [x : xs | a <- as, xs <- ramas1 a]

-- 2ª solución

ramas2 :: Arbol b -> [[b]]

ramas2 (N x []) = [[x]]

ramas2 (N x as) = concat (map (map (x:)) (map ramas2 as))

-- 3ª solución

ramas3 :: Arbol b -> [[b]]

ramas3 (N x []) = [[x]]

ramas3 (N x as) = concat (map (map (x:) . ramas3) as)

-- 4ª solución

ramas4 :: Arbol b -> [[b]]

ramas4 (N x []) = [[x]]

ramas4 (N x as) = concatMap (map (x:) . ramas4) as

-- 5ª solución

ramas5 :: Arbol a -> [[a]]

ramas5 (N x []) = [[x]]

ramas5 (N x xs) = map ramas5 xs >>= map (x:)

-- Comprobación de la equivalencia de las definiciones

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

-- (arbolArbitrario n) es un árbol aleatorio de orden n. Por ejemplo,

-- λ> sample (arbolArbitrario 4 :: Gen (Arbol Int))

-- N 0 [N 0 []]

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

-- N 1 [N (-2) [],N 0 [N (-4) [N (-2) []]]]

-- N (-4) [N 1 [],N 0 [N 6 [N (-4) []],N 2 [N 3 []]]]

-- N (-7) [N (-7) [N (-3) []]]

-- N (-2) [N (-8) []]

-- N (-3) [N 3 [N 2 []]]

-- N (-12) [N 5 [],N 0 []]

-- N 14 [N 13 [N (-12) []],N 11 [],N 8 [N (-13) []]]

-- N (-12) [N (-6) [N 16 [N (-14) [N (-1) []]]]]

-- N (-5) []

arbolArbitrario :: Arbitrary a => Int -> Gen (Arbol a)

arbolArbitrario n = do

x <- arbitrary

ms <- sublistOf [0 .. n `div` 2]

as <- mapM arbolArbitrario ms

return (N x as)

-- Arbol es una subclase de Arbitraria

instance Arbitrary a => Arbitrary (Arbol a) where

arbitrary = sized arbolArbitrario

-- La propiedad es

prop_arbol :: Arbol Int -> Bool

prop_arbol a =

all (== ramas1 a)

[ramas2 a,

ramas3 a,

ramas4 a,

ramas5 a]

-- La comprobación es

-- λ> quickCheck prop_arbol

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> ej600 <- generate (arbolArbitrario 600 :: Gen (Arbol Int))

-- λ> length (ramas1 ej600)

-- 1262732

-- (1.92 secs, 1,700,238,488 bytes)

-- λ> length (ramas2 ej600)

-- 1262732

-- (1.94 secs, 2,549,877,280 bytes)

-- λ> length (ramas3 ej600)

-- 1262732

-- (1.99 secs, 2,446,508,472 bytes)

-- λ> length (ramas4 ej600)

-- 1262732

-- (1.67 secs, 2,090,469,104 bytes)

-- λ> length (ramas5 ej600)

-- 1262732

-- (1.66 secs, 2,112,198,232 bytes)

El código se encuentra en GitHub.

La elaboración de las soluciones se describe en el siguiente vídeo

Valores de polinomios representados con vectores

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

Los polinomios se pueden representar mediante vectores usando la librería Data.Array. En primer lugar, se define el tipo de los polinomios (con coeficientes de tipo a) mediante

   type Polinomio a = Array Int a

1	type Polinomio a = Array Int a

Como ejemplos, definimos el polinomio

   ej_pol1 :: Array Int Int
   ej_pol1 = array (0,4) [(0,6),(1,2),(2,-5),(3,0),(4,7)]

1 2	ej_pol1 :: Array Int Int ej_pol1 = array (0,4) [(0,6),(1,2),(2,-5),(3,0),(4,7)]

que representa a 6 + 2x – 5x^2 + 7x^4 y el polinomio

   ej_pol2 :: Array Int Double
   ej_pol2 = array (0,4) [(0,6.5),(1,2),(2,-5.2),(3,0),(4,7)]

1 2	ej_pol2 :: Array Int Double ej_pol2 = array (0,4) [(0,6.5),(1,2),(2,-5.2),(3,0),(4,7)]

que representa a 6.5 + 2x – 5.2x^2 + 7x^4

Definir la función

   valor :: Num a => Polinomio a -> a -> a

1	valor :: Num a => Polinomio a -> a -> a

tal que (valor p b) es el valor del polinomio p en el punto b. Por ejemplo,

   valor ej_pol1 0  ==  6
   valor ej_pol1 1  ==  10
   valor ej_pol1 2  ==  102
   valor ej_pol2 0  ==  6.5
   valor ej_pol2 1  ==  10.3
   valor ej_pol2 3  ==  532.7
   length (show (valor (listArray (0,5*10^5) (repeat 1)) 2)) == 150516

valor ej_pol1 0 == 6

valor ej_pol1 1 == 10

valor ej_pol1 2 == 102

valor ej_pol2 0 == 6.5

valor ej_pol2 1 == 10.3

valor ej_pol2 3 == 532.7

length (show (valor (listArray (0,5*10^5) (repeat 1)) 2)) == 150516

Soluciones

import Data.List (foldl')
import Data.Array (Array, (!), array, assocs, bounds, elems, listArray)
import Test.QuickCheck

type Polinomio a = Array Int a

ej_pol1 :: Array Int Int
ej_pol1 = array (0,4) [(1,2),(2,-5),(4,7),(0,6),(3,0)]

ej_pol2 :: Array Int Double
ej_pol2 = array (0,4) [(1,2),(2,-5.2),(4,7),(0,6.5),(3,0)]

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

valor1 :: Num a => Polinomio a -> a -> a
valor1 p b = sum [(p!i)*b^i | i <- [0..n]]
  where (_,n) = bounds p

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

valor2 :: Num a => Polinomio a -> a -> a
valor2 p b = sum [(p!i)*b^i | i <- [0..length p - 1]]

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

valor3 :: Num a => Polinomio a -> a -> a
valor3 p b = sum [v*b^i | (i,v) <- assocs p]

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

valor4 :: Num a => Polinomio a -> a -> a
valor4 = valorLista4 . elems

valorLista4 :: Num a => [a] -> a -> a
valorLista4 xs b =
  sum [(xs !! i) * b^i | i <- [0..length xs - 1]]

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

valor5 :: Num a => Polinomio a -> a -> a
valor5 = valorLista5 . elems

valorLista5 :: Num a => [a] -> a -> a
valorLista5 []     _ = 0
valorLista5 (x:xs) b = x + b * valorLista5 xs b

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

valor6 :: Num a => Polinomio a -> a -> a
valor6 = valorLista6 . elems

valorLista6 :: Num a => [a] -> a -> a
valorLista6 xs b = aux xs
  where aux []     = 0
        aux (y:ys) = y + b * aux ys

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

valor7 :: Num a => Polinomio a -> a -> a
valor7 = valorLista7 . elems

valorLista7 :: Num a => [a] -> a -> a
valorLista7 xs b = foldr (\y r -> y + b * r) 0 xs

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

valor8 :: Num a => Polinomio a -> a -> a
valor8 = valorLista8 . elems

valorLista8 :: Num a => [a] -> a -> a
valorLista8 xs b = aux 0 (reverse xs)
  where aux r []     = r
        aux r (y:ys) = aux (y + r * b) ys

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

valor9 :: Num a => Polinomio a -> a -> a
valor9 = valorLista9 . elems

valorLista9 :: Num a => [a] -> a -> a
valorLista9 xs b = aux 0 (reverse xs)
  where aux = foldl (\ r y -> y + r * b)

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

valor10 :: Num a => Polinomio a -> a -> a
valor10 p b =
  foldl (\ r y -> y + r * b) 0 (reverse (elems p))

-- 11ª solución
-- ============

valor11 :: Num a => Polinomio a -> a -> a
valor11 p b =
  foldl' (\ r y -> y + r * b) 0 (reverse (elems p))

-- 12ª solución
-- ============

valor12 :: Num a => Polinomio a -> a -> a
valor12 p b =
  sum (zipWith (*) (elems p) (iterate (* b) 1))

-- 13ª solución
-- ============

valor13 :: Num a => Polinomio a -> a -> a
valor13 p b =
  foldl' (+) 0 (zipWith (*) (elems p) (iterate (* b) 1))

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

-- La propiedad es
prop_valor :: [Integer] -> Integer -> Bool
prop_valor xs b =
  all (== valor1 p b)
      [f p b | f <- [valor2,
                     valor3,
                     valor4,
                     valor5,
                     valor6,
                     valor7,
                     valor8,
                     valor9,
                     valor10,
                     valor11,
                     valor12,
                     valor13]]
  where p = listArray (0, length xs - 1) xs

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

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

-- La comparación es
--    λ> length (show (valor1 (listArray (0,10^5) (repeat 1)) 2))
--    30104
--    (7.62 secs, 2,953,933,864 bytes)
--    λ> length (show (valor2 (listArray (0,10^5) (repeat 1)) 2))
--    30104
--    (8.26 secs, 2,953,933,264 bytes)
--    λ> length (show (valor3 (listArray (0,10^5) (repeat 1)) 2))
--    30104
--    (7.49 secs, 2,954,733,184 bytes)
--    λ> length (show (valor4 (listArray (0,10^5) (repeat 1)) 2))
--    30104
--    (84.80 secs, 2,956,333,712 bytes)
--    λ> length (show (valor5 (listArray (0,10^5) (repeat 1)) 2))
--    30104
--    (1.34 secs, 1,307,347,416 bytes)
--    λ> length (show (valor6 (listArray (0,10^5) (repeat 1)) 2))
--    30104
--    (1.26 secs, 1,308,114,752 bytes)
--    λ> length (show (valor7 (listArray (0,10^5) (repeat 1)) 2))
--    30104
--    (1.21 secs, 1,296,843,456 bytes)
--    λ> length (show (valor8 (listArray (0,10^5) (repeat 1)) 2))
--    30104
--    (1.28 secs, 1,309,591,744 bytes)
--    λ> length (show (valor9 (listArray (0,10^5) (repeat 1)) 2))
--    30104
--    (1.27 secs, 1,299,191,672 bytes)
--    λ> length (show (valor10 (listArray (0,10^5) (repeat 1)) 2))
--    30104
--    (1.30 secs, 1,299,191,432 bytes)
--    λ> length (show (valor11 (listArray (0,10^5) (repeat 1)) 2))
--    30104
--    (0.23 secs, 1,287,654,752 bytes)
--    λ> length (show (valor12 (listArray (0,10^5) (repeat 1)) 2))
--    30104
--    (0.75 secs, 1,309,506,968 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

import Data.List (foldl')

import Data.Array (Array, (!), array, assocs, bounds, elems, listArray)

import Test.QuickCheck

type Polinomio a = Array Int a

ej_pol1 :: Array Int Int

ej_pol1 = array (0,4) [(1,2),(2,-5),(4,7),(0,6),(3,0)]

ej_pol2 :: Array Int Double

ej_pol2 = array (0,4) [(1,2),(2,-5.2),(4,7),(0,6.5),(3,0)]

-- 1ª solución

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

valor1 :: Num a => Polinomio a -> a -> a

valor1 p b = sum [(p!i)*b^i | i <- [0..n]]

where (_,n) = bounds p

-- 2ª solución

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

valor2 :: Num a => Polinomio a -> a -> a

valor2 p b = sum [(p!i)*b^i | i <- [0..length p - 1]]

-- 3ª solución

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

valor3 :: Num a => Polinomio a -> a -> a

valor3 p b = sum [v*b^i | (i,v) <- assocs p]

-- 4ª solución

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

valor4 :: Num a => Polinomio a -> a -> a

valor4 = valorLista4 . elems

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

valorLista4 xs b =

sum [(xs !! i) * b^i | i <- [0..length xs - 1]]

-- 5ª solución

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

valor5 :: Num a => Polinomio a -> a -> a

valor5 = valorLista5 . elems

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

valorLista5 [] _ = 0

valorLista5 (x:xs) b = x + b * valorLista5 xs b

-- 6ª solución

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

valor6 :: Num a => Polinomio a -> a -> a

valor6 = valorLista6 . elems

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

valorLista6 xs b = aux xs

where aux [] = 0

aux (y:ys) = y + b * aux ys

-- 7ª solución

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

valor7 :: Num a => Polinomio a -> a -> a

valor7 = valorLista7 . elems

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

valorLista7 xs b = foldr (\y r -> y + b * r) 0 xs

-- 8ª solución

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

valor8 :: Num a => Polinomio a -> a -> a

valor8 = valorLista8 . elems

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

valorLista8 xs b = aux 0 (reverse xs)

where aux r [] = r

aux r (y:ys) = aux (y + r * b) ys

-- 9ª solución

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

valor9 :: Num a => Polinomio a -> a -> a

valor9 = valorLista9 . elems

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

valorLista9 xs b = aux 0 (reverse xs)

where aux = foldl (\ r y -> y + r * b)

-- 10ª solución

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

valor10 :: Num a => Polinomio a -> a -> a

valor10 p b =

foldl (\ r y -> y + r * b) 0 (reverse (elems p))

-- 11ª solución

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

valor11 :: Num a => Polinomio a -> a -> a

valor11 p b =

foldl' (\ r y -> y + r * b) 0 (reverse (elems p))

-- 12ª solución

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

valor12 :: Num a => Polinomio a -> a -> a

valor12 p b =

sum (zipWith (*) (elems p) (iterate (* b) 1))

-- 13ª solución

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

valor13 :: Num a => Polinomio a -> a -> a

valor13 p b =

foldl' (+) 0 (zipWith (*) (elems p) (iterate (* b) 1))

-- Equivalencia de las definiciones

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

-- La propiedad es

prop_valor :: [Integer] -> Integer -> Bool

prop_valor xs b =

all (== valor1 p b)

[f p b | f <- [valor2,

valor3,

valor4,

valor5,

valor6,

valor7,

valor8,

valor9,

valor10,

valor11,

valor12,

valor13]]

where p = listArray (0, length xs - 1) xs

-- La comprobación es

-- λ> quickCheck prop_valor

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> length (show (valor1 (listArray (0,10^5) (repeat 1)) 2))

-- 30104

-- (7.62 secs, 2,953,933,864 bytes)

-- λ> length (show (valor2 (listArray (0,10^5) (repeat 1)) 2))

-- 30104

-- (8.26 secs, 2,953,933,264 bytes)

-- λ> length (show (valor3 (listArray (0,10^5) (repeat 1)) 2))

-- 30104

-- (7.49 secs, 2,954,733,184 bytes)

-- λ> length (show (valor4 (listArray (0,10^5) (repeat 1)) 2))

-- 30104

-- (84.80 secs, 2,956,333,712 bytes)

-- λ> length (show (valor5 (listArray (0,10^5) (repeat 1)) 2))

-- 30104

-- (1.34 secs, 1,307,347,416 bytes)

-- λ> length (show (valor6 (listArray (0,10^5) (repeat 1)) 2))

-- 30104

-- (1.26 secs, 1,308,114,752 bytes)

-- λ> length (show (valor7 (listArray (0,10^5) (repeat 1)) 2))

-- 30104

-- (1.21 secs, 1,296,843,456 bytes)

-- λ> length (show (valor8 (listArray (0,10^5) (repeat 1)) 2))

-- 30104

-- (1.28 secs, 1,309,591,744 bytes)

-- λ> length (show (valor9 (listArray (0,10^5) (repeat 1)) 2))

-- 30104

-- (1.27 secs, 1,299,191,672 bytes)

-- λ> length (show (valor10 (listArray (0,10^5) (repeat 1)) 2))

-- 30104

-- (1.30 secs, 1,299,191,432 bytes)

-- λ> length (show (valor11 (listArray (0,10^5) (repeat 1)) 2))

-- 30104

-- (0.23 secs, 1,287,654,752 bytes)

-- λ> length (show (valor12 (listArray (0,10^5) (repeat 1)) 2))

-- 30104

-- (0.75 secs, 1,309,506,968 bytes)

El código se encuentra en GitHub.

La elaboración de las soluciones se encuentran en el siguiente vídeo

Segmentos maximales de elementos consecutivos

PorJosé A. Alonso 11-marzo-202217-marzo-2022

Definir la función

   segmentos :: (Enum a, Eq a) => [a] -> [[a]]

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

tal que (segmentos xss) es la lista de los segmentos maximales de xss formados por elementos consecutivos. Por ejemplo,

   segmentos [1,2,5,6,4]     ==  [[1,2],[5,6],[4]]
   segmentos [1,2,3,4,7,8,9] ==  [[1,2,3,4],[7,8,9]]
   segmentos "abbccddeeebc"  ==  ["ab","bc","cd","de","e","e","bc"]

segmentos [1,2,5,6,4] == [[1,2],[5,6],[4]]

segmentos [1,2,3,4,7,8,9] == [[1,2,3,4],[7,8,9]]

segmentos "abbccddeeebc" == ["ab","bc","cd","de","e","e","bc"]

Soluciones

[schedule expon=’2022-03-18′ expat=»06:00″]

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

[/schedule]

[schedule on=’2022-03-18′ at=»06:00″]

import Test.QuickCheck

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

segmentos1 :: (Enum a, Eq a) => [a] -> [[a]]
segmentos1 []  = []
segmentos1 xs = ys : segmentos1 zs
  where ys = inicial xs
        n  = length ys
        zs = drop n xs

-- (inicial xs) es el segmento inicial de xs formado por elementos
-- consecutivos. Por ejemplo,
--    inicial [1,2,5,6,4]    ==  [1,2]
--    inicial "abccddeeebc"  ==  "abc"
inicial :: (Enum a, Eq a) => [a] -> [a]
inicial []      = []
inicial [x]     = [x]
inicial (x:y:xs)
  | succ x == y = x : inicial (y:xs)
  | otherwise   = [x]

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

segmentos2 :: (Enum a, Eq a) => [a] -> [[a]]
segmentos2 []  = []
segmentos2 xs = ys : segmentos2 zs
  where (ys,zs) = inicialYresto xs

-- (inicialYresto xs) es par formado por el segmento inicial de xs
-- con elementos consecutivos junto con los restantes elementos. Por
-- ejemplo,
--    inicialYresto [1,2,5,6,4]    ==  ([1,2],[5,6,4])
--    inicialYresto "abccddeeebc"  ==  ("abc","cddeeebc")
inicialYresto :: (Enum a, Eq a) => [a] -> ([a],[a])
inicialYresto []      = ([],[])
inicialYresto [x]     = ([x],[])
inicialYresto (x:y:xs)
  | succ x == y = (x:us,vs)
  | otherwise   = ([x],y:xs)
  where (us,vs) = inicialYresto (y:xs)

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

segmentos3 :: (Enum a, Eq a) => [a] -> [[a]]
segmentos3 []  = []
segmentos3 [x] = [[x]]
segmentos3 (x:xs) | y == succ x = (x:y:ys):zs
                  | otherwise   = [x] : (y:ys):zs
  where ((y:ys):zs) = segmentos3 xs

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

segmentos4 :: (Enum a, Eq a) => [a] -> [[a]]
segmentos4 []  = []
segmentos4 xs = ys : segmentos4 zs
  where ys = inicial4 xs
        n  = length ys
        zs = drop n xs

inicial4 :: (Enum a, Eq a) => [a] -> [a]
inicial4 [] = []
inicial4 (x:xs) =
  map fst (takeWhile (\(u,v) -> u == v) (zip (x:xs) [x..]))

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

segmentos5 :: (Enum a, Eq a) => [a] -> [[a]]
segmentos5 []  = []
segmentos5 xs = ys : segmentos5 zs
  where ys = inicial5 xs
        n  = length ys
        zs = drop n xs

inicial5 :: (Enum a, Eq a) => [a] -> [a]
inicial5 [] = []
inicial5 (x:xs) =
  map fst (takeWhile (uncurry (==)) (zip (x:xs) [x..]))

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

-- La propiedad es
prop_segmentos :: [Int] -> Bool
prop_segmentos xs =
  all (== segmentos1 xs)
      [segmentos2 xs,
       segmentos3 xs,
       segmentos4 xs,
       segmentos5 xs]

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

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

-- La comparación es
--    λ> length (segmentos1 (take (10^6) (cycle [1..10^3])))
--    1000
--    (0.69 secs, 416,742,208 bytes)
--    λ> length (segmentos2 (take (10^6) (cycle [1..10^3])))
--    1000
--    (0.66 secs, 528,861,976 bytes)
--    λ> length (segmentos3 (take (10^6) (cycle [1..10^3])))
--    1000
--    (2.35 secs, 1,016,276,896 bytes)
--    λ> length (segmentos4 (take (10^6) (cycle [1..10^3])))
--    1000
--    (0.27 secs, 409,438,368 bytes)
--    λ> length (segmentos5 (take (10^6) (cycle [1..10^3])))
--    1000
--    (0.13 secs, 401,510,360 bytes)
--
--    λ> length (segmentos4 (take (10^7) (cycle [1..10^3])))
--    10000
--    (2.35 secs, 4,088,926,920 bytes)
--    λ> length (segmentos5 (take (10^7) (cycle [1..10^3])))
--    10000
--    (1.02 secs, 4,009,646,928 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

import Test.QuickCheck

-- 1ª solución

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

segmentos1 :: (Enum a, Eq a) => [a] -> [[a]]

segmentos1 [] = []

segmentos1 xs = ys : segmentos1 zs

where ys = inicial xs

n = length ys

zs = drop n xs

-- (inicial xs) es el segmento inicial de xs formado por elementos

-- consecutivos. Por ejemplo,

-- inicial [1,2,5,6,4] == [1,2]

-- inicial "abccddeeebc" == "abc"

inicial :: (Enum a, Eq a) => [a] -> [a]

inicial [] = []

inicial [x] = [x]

inicial (x:y:xs)

| succ x == y = x : inicial (y:xs)

| otherwise = [x]

-- 2ª solución

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

segmentos2 :: (Enum a, Eq a) => [a] -> [[a]]

segmentos2 [] = []

segmentos2 xs = ys : segmentos2 zs

where (ys,zs) = inicialYresto xs

-- (inicialYresto xs) es par formado por el segmento inicial de xs

-- con elementos consecutivos junto con los restantes elementos. Por

-- ejemplo,

-- inicialYresto [1,2,5,6,4] == ([1,2],[5,6,4])

-- inicialYresto "abccddeeebc" == ("abc","cddeeebc")

inicialYresto :: (Enum a, Eq a) => [a] -> ([a],[a])

inicialYresto [] = ([],[])

inicialYresto [x] = ([x],[])

inicialYresto (x:y:xs)

| succ x == y = (x:us,vs)

| otherwise = ([x],y:xs)

where (us,vs) = inicialYresto (y:xs)

-- 3ª solución

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

segmentos3 :: (Enum a, Eq a) => [a] -> [[a]]

segmentos3 [] = []

segmentos3 [x] = [[x]]

segmentos3 (x:xs) | y == succ x = (x:y:ys):zs

| otherwise = [x] : (y:ys):zs

where ((y:ys):zs) = segmentos3 xs

-- 4ª solución

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

segmentos4 :: (Enum a, Eq a) => [a] -> [[a]]

segmentos4 [] = []

segmentos4 xs = ys : segmentos4 zs

where ys = inicial4 xs

n = length ys

zs = drop n xs

inicial4 :: (Enum a, Eq a) => [a] -> [a]

inicial4 [] = []

inicial4 (x:xs) =

map fst (takeWhile (\(u,v) -> u == v) (zip (x:xs) [x..]))

-- 5ª solución

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

segmentos5 :: (Enum a, Eq a) => [a] -> [[a]]

segmentos5 [] = []

segmentos5 xs = ys : segmentos5 zs

where ys = inicial5 xs

n = length ys

zs = drop n xs

inicial5 :: (Enum a, Eq a) => [a] -> [a]

inicial5 [] = []

inicial5 (x:xs) =

map fst (takeWhile (uncurry (==)) (zip (x:xs) [x..]))

-- Comprobación de equivalencia

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

-- La propiedad es

prop_segmentos :: [Int] -> Bool

prop_segmentos xs =

all (== segmentos1 xs)

[segmentos2 xs,

segmentos3 xs,

segmentos4 xs,

segmentos5 xs]

-- La comprobación es

-- λ> quickCheck prop_segmentos

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> length (segmentos1 (take (10^6) (cycle [1..10^3])))

-- 1000

-- (0.69 secs, 416,742,208 bytes)

-- λ> length (segmentos2 (take (10^6) (cycle [1..10^3])))

-- 1000

-- (0.66 secs, 528,861,976 bytes)

-- λ> length (segmentos3 (take (10^6) (cycle [1..10^3])))

-- 1000

-- (2.35 secs, 1,016,276,896 bytes)

-- λ> length (segmentos4 (take (10^6) (cycle [1..10^3])))

-- 1000

-- (0.27 secs, 409,438,368 bytes)

-- λ> length (segmentos5 (take (10^6) (cycle [1..10^3])))

-- 1000

-- (0.13 secs, 401,510,360 bytes)

-- λ> length (segmentos4 (take (10^7) (cycle [1..10^3])))

-- 10000

-- (2.35 secs, 4,088,926,920 bytes)

-- λ> length (segmentos5 (take (10^7) (cycle [1..10^3])))

-- 10000

-- (1.02 secs, 4,009,646,928 bytes)

El código se encuentra en [GitHub](https://github.com/jaalonso/Exercitium/blob/main/src/Segmentos_consecutivos.hs).

La elaboración de las soluciones explica en el siguiente vídeo:

[/schedule]

Lista cuadrada

PorJosé A. Alonso 10-marzo-202217-marzo-2022

Definir la función

   listaCuadrada :: Int -> a -> [a] -> [[a]]

1	listaCuadrada :: Int -> a -> [a] -> [[a]]

tal que (listaCuadrada n x xs) es una lista de n listas de longitud n formadas con los elementos de xs completada con x, si no xs no tiene suficientes elementos. Por ejemplo,

   listaCuadrada 3 7 [0,3,5,2,4]  ==  [[0,3,5],[2,4,7],[7,7,7]]
   listaCuadrada 3 7 [0..]        ==  [[0,1,2],[3,4,5],[6,7,8]]
   listaCuadrada 2 'p' "eva"      ==  ["ev","ap"]
   listaCuadrada 2 'p' ['a'..]    ==  ["ab","cd"]

listaCuadrada 3 7 [0,3,5,2,4] == [[0,3,5],[2,4,7],[7,7,7]]

listaCuadrada 3 7 [0..] == [[0,1,2],[3,4,5],[6,7,8]]

listaCuadrada 2 'p' "eva" == ["ev","ap"]

listaCuadrada 2 'p' ['a'..] == ["ab","cd"]

Soluciones

import Data.List.Split (chunksOf)
import Test.QuickCheck

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

listaCuadrada1 :: Int -> a -> [a] -> [[a]]
listaCuadrada1 n x xs =
  take n (grupos n (xs ++ repeat x))

-- (grupos n xs) es la lista obtenida agrupando los elementos de xs en
-- grupos de n elementos, salvo el último que puede tener menos. Por
-- ejemplo,
--    grupos 2 [4,2,5,7,6]     ==  [[4,2],[5,7],[6]]
--    take 3 (grupos 3 [1..])  ==  [[1,2,3],[4,5,6],[7,8,9]]
grupos :: Int -> [a] -> [[a]]
grupos _ [] = []
grupos n xs = take n xs : grupos n (drop n xs)

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

listaCuadrada2 :: Int -> a -> [a] -> [[a]]
listaCuadrada2 n x xs =
  take n (grupos2 n (xs ++ repeat x))

grupos2 :: Int -> [a] -> [[a]]
grupos2 _ [] = []
grupos2 n xs = ys : grupos n zs
  where (ys,zs) = splitAt n xs

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

listaCuadrada3 :: Int -> a -> [a] -> [[a]]
listaCuadrada3 n x xs =
  take n (chunksOf n (xs ++ repeat x))

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

-- La propiedad es
prop_listaCuadrada :: Int -> Int -> [Int] -> Bool
prop_listaCuadrada n x xs =
  all (== listaCuadrada1 n x xs)
      [listaCuadrada2 n x xs,
       listaCuadrada3 n x xs]

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

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

-- La comparación es
--    λ> length (listaCuadrada1 (10^4) 5 [1..])
--    10000
--    (2.02 secs, 12,801,918,616 bytes)
--    λ> length (listaCuadrada2 (10^4) 5 [1..])
--    10000
--    (1.89 secs, 12,803,198,576 bytes)
--    λ> length (listaCuadrada3 (10^4) 5 [1..])
--    10000
--    (1.85 secs, 12,801,518,728 bytes)

import Data.List.Split (chunksOf)

import Test.QuickCheck

-- 1ª solución

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

listaCuadrada1 :: Int -> a -> [a] -> [[a]]

listaCuadrada1 n x xs =

take n (grupos n (xs ++ repeat x))

-- (grupos n xs) es la lista obtenida agrupando los elementos de xs en

-- grupos de n elementos, salvo el último que puede tener menos. Por

-- ejemplo,

-- grupos 2 [4,2,5,7,6] == [[4,2],[5,7],[6]]

-- take 3 (grupos 3 [1..]) == [[1,2,3],[4,5,6],[7,8,9]]

grupos :: Int -> [a] -> [[a]]

grupos _ [] = []

grupos n xs = take n xs : grupos n (drop n xs)

-- 2ª solución

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

listaCuadrada2 :: Int -> a -> [a] -> [[a]]

listaCuadrada2 n x xs =

take n (grupos2 n (xs ++ repeat x))

grupos2 :: Int -> [a] -> [[a]]

grupos2 _ [] = []

grupos2 n xs = ys : grupos n zs

where (ys,zs) = splitAt n xs

-- 3ª solución

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

listaCuadrada3 :: Int -> a -> [a] -> [[a]]

listaCuadrada3 n x xs =

take n (chunksOf n (xs ++ repeat x))

-- Comprobación de la equivalencia

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

-- La propiedad es

prop_listaCuadrada :: Int -> Int -> [Int] -> Bool

prop_listaCuadrada n x xs =

all (== listaCuadrada1 n x xs)

[listaCuadrada2 n x xs,

listaCuadrada3 n x xs]

-- La comprobación es

-- λ> quickCheck prop_listaCuadrada

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> length (listaCuadrada1 (10^4) 5 [1..])

-- 10000

-- (2.02 secs, 12,801,918,616 bytes)

-- λ> length (listaCuadrada2 (10^4) 5 [1..])

-- 10000

-- (1.89 secs, 12,803,198,576 bytes)

-- λ> length (listaCuadrada3 (10^4) 5 [1..])

-- 10000

-- (1.85 secs, 12,801,518,728 bytes)

El código se encuentra en GitHub.

La elaboración de la solución se muestra en el siguiente vídeo:

Matrices de Toepliz

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

Una matriz de Toeplitz es una matriz cuadrada que es constante a lo largo de las diagonales paralelas a la diagonal principal. Por ejemplo,

   |2 5 1 6|       |2 5 1 6|
   |4 2 5 1|       |4 2 6 1|
   |7 4 2 5|       |7 4 2 5|
   |9 7 4 2|       |9 7 4 2|

|2 5 1 6| |2 5 1 6|

|4 2 5 1| |4 2 6 1|

|7 4 2 5| |7 4 2 5|

|9 7 4 2| |9 7 4 2|

la primera es una matriz de Toeplitz y la segunda no lo es.

Las anteriores matrices se pueden definir por

   ej1, ej2 :: Array (Int,Int) Int
   ej1 = listArray ((1,1),(4,4)) [2,5,1,6,4,2,5,1,7,4,2,5,9,7,4,2]
   ej2 = listArray ((1,1),(4,4)) [2,5,1,6,4,2,6,1,7,4,2,5,9,7,4,2]

ej1, ej2 :: Array (Int,Int) Int

ej1 = listArray ((1,1),(4,4)) [2,5,1,6,4,2,5,1,7,4,2,5,9,7,4,2]

ej2 = listArray ((1,1),(4,4)) [2,5,1,6,4,2,6,1,7,4,2,5,9,7,4,2]

Definir la función

   esToeplitz :: Eq a => Array (Int,Int) a -> Bool

1	esToeplitz :: Eq a => Array (Int,Int) a -> Bool

tal que (esToeplitz p) se verifica si la matriz p es de Toeplitz. Por ejemplo,

   esToeplitz ej1  ==  True
   esToeplitz ej2  ==  False

1 2	esToeplitz ej1 == True esToeplitz ej2 == False

Soluciones

import Data.Array (Array, (!), bounds, listArray)

ej1, ej2 :: Array (Int,Int) Int
ej1 = listArray ((1,1),(4,4)) [2,5,1,6,4,2,5,1,7,4,2,5,9,7,4,2]
ej2 = listArray ((1,1),(4,4)) [2,5,1,6,4,2,6,1,7,4,2,5,9,7,4,2]

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

esToeplitz1 :: Eq a => Array (Int,Int) a -> Bool
esToeplitz1 p =
  esCuadrada p &&
  all todosIguales (diagonalesPrincipales p)

-- (esCuadrada p) se verifica si la matriz p es cuadrada. Por ejemplo,
--    esCuadrada (listArray ((1,1),(4,4)) [1..])  ==  True
--    esCuadrada (listArray ((1,1),(3,4)) [1..])  ==  False
esCuadrada :: Eq a => Array (Int,Int) a -> Bool
esCuadrada p = m == n
  where (_,(m,n)) = bounds p

-- (diagonalesPrincipales p) es la lista de las diagonales principales
-- de p. Por ejemplo,
--    λ> diagonalesPrincipales ej1
--    [[2,2,2,2],[5,5,5],[1,1],[6],[2,2,2,2],[4,4,4],[7,7],[9]]
--    λ> diagonalesPrincipales ej2
--    [[2,2,2,2],[5,6,5],[1,1],[6],[2,2,2,2],[4,4,4],[7,7],[9]]
diagonalesPrincipales :: Array (Int,Int) a -> [[a]]
diagonalesPrincipales p =
  [[p ! i |i <- is] | is <- posicionesDiagonalesPrincipales m n]
  where (_,(m,n)) = bounds p

-- (posicionesDiagonalesPrincipales m n) es la lista de las
-- posiciones de las diagonales principales de una matriz con m filas y
-- n columnas. Por ejemplo,
--   λ> mapM_ print (posicionesDiagonalesPrincipales 3 4)
--   [(3,1)]
--   [(2,1),(3,2)]
--   [(1,1),(2,2),(3,3)]
--   [(1,2),(2,3),(3,4)]
--   [(1,3),(2,4)]
--   [(1,4)]
--   λ> mapM_ print (posicionesDiagonalesPrincipales 4 4)
--   [(4,1)]
--   [(3,1),(4,2)]
--   [(2,1),(3,2),(4,3)]
--   [(1,1),(2,2),(3,3),(4,4)]
--   [(1,2),(2,3),(3,4)]
--   [(1,3),(2,4)]
--   [(1,4)]
--   λ> mapM_ print (posicionesDiagonalesPrincipales 4 3)
--   [(4,1)]
--   [(3,1),(4,2)]
--   [(2,1),(3,2),(4,3)]
--   [(1,1),(2,2),(3,3)]
--   [(1,2),(2,3)]
--   [(1,3)]
posicionesDiagonalesPrincipales :: Int -> Int -> [[(Int, Int)]]
posicionesDiagonalesPrincipales m n =
  [zip [i..m] [1..n] | i <- [m,m-1..1]] ++
  [zip [1..m] [j..n] | j <- [2..n]]

-- (todosIguales xs) se verifica si todos los elementos de xs son
-- iguales. Por ejemplo,
--    todosIguales [5,5,5]  ==  True
--    todosIguales [5,4,5]  ==  False
todosIguales :: Eq a => [a] -> Bool
todosIguales []     = True
todosIguales (x:xs) = all (== x) xs

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

esToeplitz2 :: Eq a => Array (Int,Int) a -> Bool
esToeplitz2 p = m == n &&
               and [p!(i,j) == p!(i+1,j+1) |
                    i <- [1..n-1], j <- [1..n-1]]
  where (_,(m,n)) = bounds p

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

-- La comparación es
--    λ> esToeplitz1 (listArray ((1,1),(2*10^3,2*10^3)) (repeat 1))
--    True
--    (2.26 secs, 2,211,553,888 bytes)
--    λ> esToeplitz2 (listArray ((1,1),(2*10^3,2*10^3)) (repeat 1))
--    True
--    (4.26 secs, 3,421,651,032 bytes)

import Data.Array (Array, (!), bounds, listArray)

ej1, ej2 :: Array (Int,Int) Int

ej1 = listArray ((1,1),(4,4)) [2,5,1,6,4,2,5,1,7,4,2,5,9,7,4,2]

ej2 = listArray ((1,1),(4,4)) [2,5,1,6,4,2,6,1,7,4,2,5,9,7,4,2]

-- 1ª solución

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

esToeplitz1 :: Eq a => Array (Int,Int) a -> Bool

esToeplitz1 p =

esCuadrada p &&

all todosIguales (diagonalesPrincipales p)

-- (esCuadrada p) se verifica si la matriz p es cuadrada. Por ejemplo,

-- esCuadrada (listArray ((1,1),(4,4)) [1..]) == True

-- esCuadrada (listArray ((1,1),(3,4)) [1..]) == False

esCuadrada :: Eq a => Array (Int,Int) a -> Bool

esCuadrada p = m == n

where (_,(m,n)) = bounds p

-- (diagonalesPrincipales p) es la lista de las diagonales principales

-- de p. Por ejemplo,

-- λ> diagonalesPrincipales ej1

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

-- λ> diagonalesPrincipales ej2

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

diagonalesPrincipales :: Array (Int,Int) a -> [[a]]

diagonalesPrincipales p =

[[p ! i |i <- is] | is <- posicionesDiagonalesPrincipales m n]

where (_,(m,n)) = bounds p

-- (posicionesDiagonalesPrincipales m n) es la lista de las

-- posiciones de las diagonales principales de una matriz con m filas y

-- n columnas. Por ejemplo,

-- λ> mapM_ print (posicionesDiagonalesPrincipales 3 4)

-- [(3,1)]

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

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

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

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

-- [(1,4)]

-- λ> mapM_ print (posicionesDiagonalesPrincipales 4 4)

-- [(4,1)]

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

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

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

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

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

-- [(1,4)]

-- λ> mapM_ print (posicionesDiagonalesPrincipales 4 3)

-- [(4,1)]

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

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

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

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

-- [(1,3)]

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

posicionesDiagonalesPrincipales m n =

[zip [i..m] [1..n] | i <- [m,m-1..1]] ++

[zip [1..m] [j..n] | j <- [2..n]]

-- (todosIguales xs) se verifica si todos los elementos de xs son

-- iguales. Por ejemplo,

-- todosIguales [5,5,5] == True

-- todosIguales [5,4,5] == False

todosIguales :: Eq a => [a] -> Bool

todosIguales [] = True

todosIguales (x:xs) = all (== x) xs

-- 2ª solución

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

esToeplitz2 :: Eq a => Array (Int,Int) a -> Bool

esToeplitz2 p = m == n &&

and [p!(i,j) == p!(i+1,j+1) |

i <- [1..n-1], j <- [1..n-1]]

where (_,(m,n)) = bounds p

-- Comparación de eficiencia

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

-- La comparación es

-- λ> esToeplitz1 (listArray ((1,1),(2*10^3,2*10^3)) (repeat 1))

-- True

-- (2.26 secs, 2,211,553,888 bytes)

-- λ> esToeplitz2 (listArray ((1,1),(2*10^3,2*10^3)) (repeat 1))

-- True

-- (4.26 secs, 3,421,651,032 bytes)

El código se encuentra en GitHub.

Suma si todos los valores son justos

PorJosé A. Alonso 3-marzo-202210-marzo-2022

Definir la función

   sumaSiTodosJustos :: (Num a, Eq a) => [Maybe a] -> Maybe a

1	sumaSiTodosJustos :: (Num a, Eq a) => [Maybe a] -> Maybe a

tal que (sumaSiTodosJustos xs) es justo la suma de todos los elementos de xs si todos son justos (es decir, si Nothing no pertenece a xs) y Nothing en caso contrario. Por ejemplo,

   sumaSiTodosJustos [Just 2, Just 5]           == Just 7
   sumaSiTodosJustos [Just 2, Just 5, Nothing]  == Nothing

1 2	sumaSiTodosJustos [Just 2, Just 5] == Just 7 sumaSiTodosJustos [Just 2, Just 5, Nothing] == Nothing

Soluciones

import Data.Maybe (catMaybes, isJust, fromJust)
import Test.QuickCheck (quickCheck)

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

sumaSiTodosJustos1 :: (Num a, Eq a) => [Maybe a] -> Maybe a
sumaSiTodosJustos1 xs
  | todosJustos xs = Just (sum [x | (Just x) <- xs])
  | otherwise      = Nothing

-- (todosJustos xs) se verifica si todos los elementos de xs son justos
-- (es decir, si Nothing no pertenece a xs) y Nothing en caso
-- contrario. Por ejemplo,
--    todosJustos [Just 2, Just 5]           == True
--    todosJustos [Just 2, Just 5, Nothing]  == False

-- 1ª definición de todosJustos:
todosJustos1 :: Eq a => [Maybe a] -> Bool
todosJustos1 = notElem Nothing

-- 2ª definición de todosJustos:
todosJustos :: Eq a => [Maybe a] -> Bool
todosJustos = all isJust

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

sumaSiTodosJustos2 :: (Num a, Eq a) => [Maybe a] -> Maybe a
sumaSiTodosJustos2 xs
  | todosJustos xs = Just (sum [fromJust x | x <- xs])
  | otherwise      = Nothing

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

sumaSiTodosJustos3 :: (Num a, Eq a) => [Maybe a] -> Maybe a
sumaSiTodosJustos3 xs
  | todosJustos xs = Just (sum (map fromJust xs))
  | otherwise      = Nothing

-- 4ª solución

sumaSiTodosJustos4 :: (Num a, Eq a) => [Maybe a] -> Maybe a
sumaSiTodosJustos4 xs
  | todosJustos xs = Just (sum (catMaybes xs))
  | otherwise      = Nothing

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

sumaSiTodosJustos5 :: (Num a, Eq a) => [Maybe a] -> Maybe a
sumaSiTodosJustos5 xs = suma (sequence xs)
  where suma Nothing   = Nothing
        suma (Just ys) = Just (sum ys)

-- Nota. En la solución anterior se usa la función
--    sequence :: Monad m => [m a] -> m [a]
-- tal que (sequence xs) es la mónada obtenida evaluando cada una de las
-- de xs de izquierda a derecha. Por ejemplo,
--    sequence [Just 2, Just 5]   ==  Just [2,5]
--    sequence [Just 2, Nothing]  ==  Nothing
--    sequence [[2,4],[5,7]]      ==  [[2,5],[2,7],[4,5],[4,7]]
--    sequence [[2,4],[5,7],[6]]  ==  [[2,5,6],[2,7,6],[4,5,6],[4,7,6]]
--    sequence [[2,4],[5,7],[]]   ==  []

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

sumaSiTodosJustos6 :: (Num a, Eq a) => [Maybe a] -> Maybe a
sumaSiTodosJustos6 xs = fmap sum (sequence xs)

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

sumaSiTodosJustos7 :: (Num a, Eq a) => [Maybe a] -> Maybe a
sumaSiTodosJustos7 = fmap sum . sequence

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

-- La propiedad es
prop_sumaSiTodosJustos :: [Maybe Integer] -> Bool
prop_sumaSiTodosJustos xs =
  all (== sumaSiTodosJustos1 xs)
      [sumaSiTodosJustos2 xs,
       sumaSiTodosJustos3 xs,
       sumaSiTodosJustos4 xs,
       sumaSiTodosJustos5 xs,
       sumaSiTodosJustos6 xs,
       sumaSiTodosJustos7 xs]

verifica_sumaSiTodosJustos :: IO ()
verifica_sumaSiTodosJustos =
  quickCheck prop_sumaSiTodosJustos

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

import Data.Maybe (catMaybes, isJust, fromJust)

import Test.QuickCheck (quickCheck)

-- 1ª solución

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

sumaSiTodosJustos1 :: (Num a, Eq a) => [Maybe a] -> Maybe a

sumaSiTodosJustos1 xs

| todosJustos xs = Just (sum [x | (Just x) <- xs])

| otherwise = Nothing

-- (todosJustos xs) se verifica si todos los elementos de xs son justos

-- (es decir, si Nothing no pertenece a xs) y Nothing en caso

-- contrario. Por ejemplo,

-- todosJustos [Just 2, Just 5] == True

-- todosJustos [Just 2, Just 5, Nothing] == False

-- 1ª definición de todosJustos:

todosJustos1 :: Eq a => [Maybe a] -> Bool

todosJustos1 = notElem Nothing

-- 2ª definición de todosJustos:

todosJustos :: Eq a => [Maybe a] -> Bool

todosJustos = all isJust

-- 2ª solución

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

sumaSiTodosJustos2 :: (Num a, Eq a) => [Maybe a] -> Maybe a

sumaSiTodosJustos2 xs

| todosJustos xs = Just (sum [fromJust x | x <- xs])

| otherwise = Nothing

-- 3ª solución

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

sumaSiTodosJustos3 :: (Num a, Eq a) => [Maybe a] -> Maybe a

sumaSiTodosJustos3 xs

| todosJustos xs = Just (sum (map fromJust xs))

| otherwise = Nothing

-- 4ª solución

sumaSiTodosJustos4 :: (Num a, Eq a) => [Maybe a] -> Maybe a

sumaSiTodosJustos4 xs

| todosJustos xs = Just (sum (catMaybes xs))

| otherwise = Nothing

-- 5ª solución

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

sumaSiTodosJustos5 :: (Num a, Eq a) => [Maybe a] -> Maybe a

sumaSiTodosJustos5 xs = suma (sequence xs)

where suma Nothing = Nothing

suma (Just ys) = Just (sum ys)

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

-- sequence :: Monad m => [m a] -> m [a]

-- tal que (sequence xs) es la mónada obtenida evaluando cada una de las

-- de xs de izquierda a derecha. Por ejemplo,

-- sequence [Just 2, Just 5] == Just [2,5]

-- sequence [Just 2, Nothing] == Nothing

-- sequence [[2,4],[5,7]] == [[2,5],[2,7],[4,5],[4,7]]

-- sequence [[2,4],[5,7],[6]] == [[2,5,6],[2,7,6],[4,5,6],[4,7,6]]

-- sequence [[2,4],[5,7],[]] == []

-- 6ª solución

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

sumaSiTodosJustos6 :: (Num a, Eq a) => [Maybe a] -> Maybe a

sumaSiTodosJustos6 xs = fmap sum (sequence xs)

-- 7ª solución

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

sumaSiTodosJustos7 :: (Num a, Eq a) => [Maybe a] -> Maybe a

sumaSiTodosJustos7 = fmap sum . sequence

-- Equivalencia de las definiciones

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

-- La propiedad es

prop_sumaSiTodosJustos :: [Maybe Integer] -> Bool

prop_sumaSiTodosJustos xs =

all (== sumaSiTodosJustos1 xs)

[sumaSiTodosJustos2 xs,

sumaSiTodosJustos3 xs,

sumaSiTodosJustos4 xs,

sumaSiTodosJustos5 xs,

sumaSiTodosJustos6 xs,

sumaSiTodosJustos7 xs]

verifica_sumaSiTodosJustos :: IO ()

verifica_sumaSiTodosJustos =

quickCheck prop_sumaSiTodosJustos

-- La comprobación es

-- λ> verifica_sumaSiTodosJustos

-- +++ OK, passed 100 tests.

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.

Ordenación por el máximo

PorJosé A. Alonso 25-febrero-20224-marzo-2022

Definir la función

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

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

tal que (ordenadosPorMaximo xss) es la lista de los elementos de xss ordenada por sus máximos (se supone que los elementos de xss son listas no vacía) y cuando tiene el mismo máximo se conserva el orden original. Por ejemplo,

   λ> ordenadosPorMaximo [[0,8],[9],[8,1],[6,3],[8,2],[6,1],[6,2]]
   [[6,3],[6,1],[6,2],[0,8],[8,1],[8,2],[9]]
   λ> ordenadosPorMaximo ["este","es","el","primero"]
   ["el","primero","es","este"]

λ> ordenadosPorMaximo [[0,8],[9],[8,1],[6,3],[8,2],[6,1],[6,2]]

[[6,3],[6,1],[6,2],[0,8],[8,1],[8,2],[9]]

λ> ordenadosPorMaximo ["este","es","el","primero"]

["el","primero","es","este"]

Soluciones

import Data.List (sort, sortBy)
import GHC.Exts (sortWith)
import Test.QuickCheck (quickCheck)

-- 1ª solución
ordenadosPorMaximo1 :: Ord a => [[a]] -> [[a]]
ordenadosPorMaximo1 xss =
  map snd (sort [((maximum xs,k),xs) | (k,xs) <- zip [0..] xss])

-- 2ª solución
ordenadosPorMaximo2 :: Ord a => [[a]] -> [[a]]
ordenadosPorMaximo2 xss =
  [xs | (_,xs) <- sort [((maximum xs,k),xs) | (k,xs) <- zip [0..] xss]]

-- 3ª solución
ordenadosPorMaximo3 :: Ord a => [[a]] -> [[a]]
ordenadosPorMaximo3 =
  sortBy (\xs ys -> compare (maximum xs) (maximum ys))

-- 4ª solución
ordenadosPorMaximo4 :: Ord a => [[a]] -> [[a]]
ordenadosPorMaximo4 = sortWith maximum

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

-- La propiedad es
prop_ordenadosPorMaximo :: [[Int]] -> Bool
prop_ordenadosPorMaximo xss =
  all (== ordenadosPorMaximo1 yss)
      [ordenadosPorMaximo2 yss,
       ordenadosPorMaximo3 yss,
       ordenadosPorMaximo4 yss]
  where yss = filter (not . null) xss

verifica_ordenadosPorMaximo :: IO ()
verifica_ordenadosPorMaximo =
  quickCheck prop_ordenadosPorMaximo

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

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

-- La comparación es
--    λ> length (ordenadosPorMaximo1 [[1..k] | k <- [1..10^4]])
--    10000
--    (6.00 secs, 8,763,714,848 bytes)
--    λ> length (ordenadosPorMaximo2 [[1..k] | k <- [1..10^4]])
--    10000
--    (6.15 secs, 8,764,177,472 bytes)
--    λ> length (ordenadosPorMaximo3 [[1..k] | k <- [1..10^4]])
--    10000
--    (8.16 secs, 13,914,503,672 bytes)
--    λ> length (ordenadosPorMaximo4 [[1..k] | k <- [1..10^4]])
--    10000
--    (7.77 secs, 13,914,183,776 bytes)

import Data.List (sort, sortBy)

import GHC.Exts (sortWith)

import Test.QuickCheck (quickCheck)

-- 1ª solución

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

ordenadosPorMaximo1 xss =

map snd (sort [((maximum xs,k),xs) | (k,xs) <- zip [0..] xss])

-- 2ª solución

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

ordenadosPorMaximo2 xss =

[xs | (_,xs) <- sort [((maximum xs,k),xs) | (k,xs) <- zip [0..] xss]]

-- 3ª solución

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

ordenadosPorMaximo3 =

sortBy (\xs ys -> compare (maximum xs) (maximum ys))

-- 4ª solución

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

ordenadosPorMaximo4 = sortWith maximum

-- Equivalencia de las definiciones

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

-- La propiedad es

prop_ordenadosPorMaximo :: [[Int]] -> Bool

prop_ordenadosPorMaximo xss =

all (== ordenadosPorMaximo1 yss)

[ordenadosPorMaximo2 yss,

ordenadosPorMaximo3 yss,

ordenadosPorMaximo4 yss]

where yss = filter (not . null) xss

verifica_ordenadosPorMaximo :: IO ()

verifica_ordenadosPorMaximo =

quickCheck prop_ordenadosPorMaximo

-- La comprobación es

-- λ> verifica_ordenadosPorMaximo

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> length (ordenadosPorMaximo1 [[1..k] | k <- [1..10^4]])

-- 10000

-- (6.00 secs, 8,763,714,848 bytes)

-- λ> length (ordenadosPorMaximo2 [[1..k] | k <- [1..10^4]])

-- 10000

-- (6.15 secs, 8,764,177,472 bytes)

-- λ> length (ordenadosPorMaximo3 [[1..k] | k <- [1..10^4]])

-- 10000

-- (8.16 secs, 13,914,503,672 bytes)

-- λ> length (ordenadosPorMaximo4 [[1..k] | k <- [1..10^4]])

-- 10000

-- (7.77 secs, 13,914,183,776 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.

Suma de los números amigos menores que n

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

Dos números amigos son dos números enteros positivos distintos tales que la suma de los divisores propios de cada uno es igual al otro. Los divisores propios de un número incluyen la unidad pero no al propio número. Por ejemplo, los divisores propios de 220 son 1, 2, 4, 5, 10, 11, 20, 22, 44, 55 y 110. La suma de estos números equivale a 284. A su vez, los divisores propios de 284 son 1, 2, 4, 71 y 142. Su suma equivale a 220. Por tanto, 220 y 284 son amigos.

Definir la función

   sumaAmigosMenores :: Integer -> Integer

1	sumaAmigosMenores :: Integer -> Integer

tal que (sumaAmigosMenores n) es la suma de los números amigos menores que n. Por ejemplo,

   sumaAmigosMenores 2000   == 2898
   sumaAmigosMenores (10^5) == 852810

1 2	sumaAmigosMenores 2000 == 2898 sumaAmigosMenores (10^5) == 852810

Soluciones

import Data.List (genericLength, group, inits, nub, sort, subsequences)
import Data.Numbers.Primes (primeFactors)

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

sumaAmigosMenores1 :: Integer -> Integer
sumaAmigosMenores1 n =
  sum [x+y | (x,y) <- amigosMenores1 n]

-- (amigosMenores1 n) es la lista de los pares de números amigos (con la
-- primera componente menor que la segunda) que son menores que n. Por
-- ejemplo,
--    amigosMenores1 2000  ==  [(220,284),(1184,1210)]
amigosMenores1 :: Integer -> [(Integer,Integer)]
amigosMenores1 n =
  takeWhile (\(_,y) -> y < n) sucesionAmigos1

sucesionAmigos1 :: [(Integer,Integer)]
sucesionAmigos1 =
  [(x,y) | x <- [1..],
           let y = sumaDivisoresPropios1 x,
           y > x,
           sumaDivisoresPropios1 y == x]

-- (sumaDivisoresPropios1 x) es la suma de los divisores propios de
-- x. Por ejemplo,
--    sumaDivisoresPropios1 220  ==  284
--    sumaDivisoresPropios1 284  ==  220
sumaDivisoresPropios1 :: Integer -> Integer
sumaDivisoresPropios1 = sum . divisoresPropios1

-- (divisoresPropios1 x) es la lista de los divisores propios de x. Por
-- ejemplo,
--    divisoresPropios1 220  ==  [1,2,4,5,10,11,20,22,44,55,110]
--    divisoresPropios1 284  ==  [1,2,4,71,142]
divisoresPropios1 :: Integer -> [Integer]
divisoresPropios1 x = [n | n <- [1..x-1], x `mod` n == 0]

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

sumaAmigosMenores2 :: Integer -> Integer
sumaAmigosMenores2 n =
  sum [x+y | (x,y) <- amigosMenores2 n]

amigosMenores2 :: Integer -> [(Integer,Integer)]
amigosMenores2 n =
  takeWhile (\(_,y) -> y < n) sucesionAmigos2

sucesionAmigos2 :: [(Integer,Integer)]
sucesionAmigos2 =
  [(x,y) | x <- [1..],
           let y = sumaDivisoresPropios2 x,
           y > x,
           sumaDivisoresPropios2 y == x]

sumaDivisoresPropios2 :: Integer -> Integer
sumaDivisoresPropios2 = sum . divisoresPropios2

divisoresPropios2 :: Integer -> [Integer]
divisoresPropios2 x = filter ((== 0) . mod x) [1..x-1]

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

sumaAmigosMenores3 :: Integer -> Integer
sumaAmigosMenores3 n =
  sum [x+y | (x,y) <- amigosMenores3 n]

amigosMenores3 :: Integer -> [(Integer,Integer)]
amigosMenores3 n =
  takeWhile (\(_,y) -> y < n) sucesionAmigos3

sucesionAmigos3 :: [(Integer,Integer)]
sucesionAmigos3 =
  [(x,y) | x <- [1..],
           let y = sumaDivisoresPropios3 x,
           y > x,
           sumaDivisoresPropios3 y == x]

sumaDivisoresPropios3 :: Integer -> Integer
sumaDivisoresPropios3 = sum . divisoresPropios3

divisoresPropios3 :: Integer -> [Integer]
divisoresPropios3 =
  init . nub . sort . map product . subsequences . primeFactors

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

sumaAmigosMenores4 :: Integer -> Integer
sumaAmigosMenores4 n =
  sum [x+y | (x,y) <- amigosMenores4 n]

amigosMenores4 :: Integer -> [(Integer,Integer)]
amigosMenores4 n =
  takeWhile (\(_,y) -> y < n) sucesionAmigos4

sucesionAmigos4 :: [(Integer,Integer)]
sucesionAmigos4 =
  [(x,y) | x <- [1..],
           let y = sumaDivisoresPropios4 x,
           y > x,
           sumaDivisoresPropios4 y == x]

sumaDivisoresPropios4 :: Integer -> Integer
sumaDivisoresPropios4 = sum . divisoresPropios4

divisoresPropios4 :: Integer -> [Integer]
divisoresPropios4 =
  init
  . sort
  . map (product . concat)
  . productoCartesiano
  . map inits
  . group
  . primeFactors

-- (productoCartesiano xss) es el producto cartesiano de los conjuntos
-- xss. Por ejemplo,
--    λ> productoCartesiano [[1,3],[2,5],[6,4]]
--    [[1,2,6],[1,2,4],[1,5,6],[1,5,4],[3,2,6],[3,2,4],[3,5,6],[3,5,4]]
productoCartesiano :: [[a]] -> [[a]]
productoCartesiano []       = [[]]
productoCartesiano (xs:xss) =
  [x:ys | x <- xs, ys <- productoCartesiano xss]

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

sumaAmigosMenores5 :: Integer -> Integer
sumaAmigosMenores5 n =
  sum [x+y | (x,y) <- amigosMenores5 n]

amigosMenores5 :: Integer -> [(Integer,Integer)]
amigosMenores5 n =
  takeWhile (\(_,y) -> y < n) sucesionAmigos5

sucesionAmigos5 :: [(Integer,Integer)]
sucesionAmigos5 =
  [(x,y) | x <- [1..],
           let y = sumaDivisoresPropios5 x,
           y > x,
           sumaDivisoresPropios5 y == x]

sumaDivisoresPropios5 :: Integer -> Integer
sumaDivisoresPropios5 = sum . divisoresPropios5

divisoresPropios5 :: Integer -> [Integer]
divisoresPropios5 =
  init
  . sort
  . map (product . concat)
  . sequence
  . map inits
  . group
  . primeFactors

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

sumaAmigosMenores6 :: Integer -> Integer
sumaAmigosMenores6 n =
  sum [x+y | (x,y) <- amigosMenores6 n]

amigosMenores6 :: Integer -> [(Integer,Integer)]
amigosMenores6 n =
  takeWhile (\(_,y) -> y < n) sucesionAmigos6

sucesionAmigos6 :: [(Integer,Integer)]
sucesionAmigos6 =
  [(x,y) | x <- [1..],
           let y = sumaDivisoresPropios6 x,
           y > x,
           sumaDivisoresPropios6 y == x]

sumaDivisoresPropios6 :: Integer -> Integer
sumaDivisoresPropios6 =
  sum
  . init
  . map (product . concat)
  . sequence
  . map inits
  . group
  . primeFactors

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

sumaAmigosMenores7 :: Integer -> Integer
sumaAmigosMenores7 n =
  sum [x+y | (x,y) <- amigosMenores7 n]

amigosMenores7 :: Integer -> [(Integer,Integer)]
amigosMenores7 n =
  takeWhile (\(_,y) -> y < n) sucesionAmigos7

sucesionAmigos7 :: [(Integer,Integer)]
sucesionAmigos7 =
  [(x,y) | x <- [1..],
           let y = sumaDivisoresPropios7 x,
           y > x,
           sumaDivisoresPropios7 y == x]

-- Si la descomposición de x en factores primos es
--    x = p(1)^e(1) . p(2)^e(2) . .... . p(n)^e(n)
-- entonces la suma de los divisores de x es
--    p(1)^(e(1)+1) - 1     p(2)^(e(2)+1) - 1       p(n)^(e(2)+1) - 1
--   ------------------- . ------------------- ... -------------------
--        p(1)-1                p(2)-1                  p(n)-1
-- Ver la demostración en http://bit.ly/2zUXZPc

sumaDivisoresPropios7 :: Integer -> Integer
sumaDivisoresPropios7 x =
  product [(p^(e+1)-1) `div` (p-1) | (p,e) <- factorizacion x] - x

-- (factorizacion x) es la lista de las bases y exponentes de la
-- descomposición prima de x. Por ejemplo,
--    factorizacion 600  ==  [(2,3),(3,1),(5,2)]
factorizacion :: Integer -> [(Integer,Integer)]
factorizacion = map primeroYlongitud . group . primeFactors

-- (primeroYlongitud xs) es el par formado por el primer elemento de xs
-- y la longitud de xs. Por ejemplo,
--    primeroYlongitud [3,2,5,7] == (3,4)
primeroYlongitud :: [a] -> (a,Integer)
primeroYlongitud (x:xs) = (x, 1 + genericLength xs)

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

-- La comparación es
--    λ> sumaAmigosMenores1 6000
--    19026
--    (10.37 secs, 5,261,392,352 bytes)
--    λ> sumaAmigosMenores2 6000
--    19026
--    (3.86 secs, 3,161,700,400 bytes)
--    λ> sumaAmigosMenores3 6000
--    19026
--    (0.15 secs, 308,520,248 bytes)
--    λ> sumaAmigosMenores4 6000
--    19026
--    (0.23 secs, 271,421,184 bytes)
--    λ> sumaAmigosMenores5 6000
--    19026
--    (0.13 secs, 230,042,112 bytes)
--    λ> sumaAmigosMenores6 6000
--    19026
--    (0.12 secs, 202,638,880 bytes)
--    λ> sumaAmigosMenores7 6000
--    19026
--    (0.13 secs, 159,022,448 bytes)
--
--    λ> sumaAmigosMenores3 (10^5)
--    852810
--    (4.83 secs, 10,726,377,728 bytes)
--    λ> sumaAmigosMenores4 (10^5)
--    852810
--    (4.79 secs, 7,832,234,120 bytes)
--    λ> sumaAmigosMenores5 (10^5)
--    852810
--    (2.79 secs, 6,837,118,464 bytes)
--    λ> sumaAmigosMenores6 (10^5)
--    852810
--    (2.39 secs, 6,229,730,472 bytes)
--    λ> sumaAmigosMenores7 (10^5)
--    852810
--    (2.65 secs, 5,170,949,168 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

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

import Data.List (genericLength, group, inits, nub, sort, subsequences)

import Data.Numbers.Primes (primeFactors)

-- 1ª solución --

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

sumaAmigosMenores1 :: Integer -> Integer

sumaAmigosMenores1 n =

sum [x+y | (x,y) <- amigosMenores1 n]

-- (amigosMenores1 n) es la lista de los pares de números amigos (con la

-- primera componente menor que la segunda) que son menores que n. Por

-- ejemplo,

-- amigosMenores1 2000 == [(220,284),(1184,1210)]

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

amigosMenores1 n =

takeWhile (\(_,y) -> y < n) sucesionAmigos1

sucesionAmigos1 :: [(Integer,Integer)]

sucesionAmigos1 =

[(x,y) | x <- [1..],

let y = sumaDivisoresPropios1 x,

y > x,

sumaDivisoresPropios1 y == x]

-- (sumaDivisoresPropios1 x) es la suma de los divisores propios de

-- x. Por ejemplo,

-- sumaDivisoresPropios1 220 == 284

-- sumaDivisoresPropios1 284 == 220

sumaDivisoresPropios1 :: Integer -> Integer

sumaDivisoresPropios1 = sum . divisoresPropios1

-- (divisoresPropios1 x) es la lista de los divisores propios de x. Por

-- ejemplo,

-- divisoresPropios1 220 == [1,2,4,5,10,11,20,22,44,55,110]

-- divisoresPropios1 284 == [1,2,4,71,142]

divisoresPropios1 :: Integer -> [Integer]

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

-- 2ª solución --

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

sumaAmigosMenores2 :: Integer -> Integer

sumaAmigosMenores2 n =

sum [x+y | (x,y) <- amigosMenores2 n]

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

amigosMenores2 n =

takeWhile (\(_,y) -> y < n) sucesionAmigos2

sucesionAmigos2 :: [(Integer,Integer)]

sucesionAmigos2 =

[(x,y) | x <- [1..],

let y = sumaDivisoresPropios2 x,

y > x,

sumaDivisoresPropios2 y == x]

sumaDivisoresPropios2 :: Integer -> Integer

sumaDivisoresPropios2 = sum . divisoresPropios2

divisoresPropios2 :: Integer -> [Integer]

divisoresPropios2 x = filter ((== 0) . mod x) [1..x-1]

-- 3ª solución --

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

sumaAmigosMenores3 :: Integer -> Integer

sumaAmigosMenores3 n =

sum [x+y | (x,y) <- amigosMenores3 n]

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

amigosMenores3 n =

takeWhile (\(_,y) -> y < n) sucesionAmigos3

sucesionAmigos3 :: [(Integer,Integer)]

sucesionAmigos3 =

[(x,y) | x <- [1..],

let y = sumaDivisoresPropios3 x,

y > x,

sumaDivisoresPropios3 y == x]

sumaDivisoresPropios3 :: Integer -> Integer

sumaDivisoresPropios3 = sum . divisoresPropios3

divisoresPropios3 :: Integer -> [Integer]

divisoresPropios3 =

init . nub . sort . map product . subsequences . primeFactors

-- 4ª solución --

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

sumaAmigosMenores4 :: Integer -> Integer

sumaAmigosMenores4 n =

sum [x+y | (x,y) <- amigosMenores4 n]

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

amigosMenores4 n =

takeWhile (\(_,y) -> y < n) sucesionAmigos4

sucesionAmigos4 :: [(Integer,Integer)]

sucesionAmigos4 =

[(x,y) | x <- [1..],

let y = sumaDivisoresPropios4 x,

y > x,

sumaDivisoresPropios4 y == x]

sumaDivisoresPropios4 :: Integer -> Integer

sumaDivisoresPropios4 = sum . divisoresPropios4

divisoresPropios4 :: Integer -> [Integer]

divisoresPropios4 =

init

. sort

. map (product . concat)

. productoCartesiano

. map inits

. group

. primeFactors

-- (productoCartesiano xss) es el producto cartesiano de los conjuntos

-- xss. Por ejemplo,

-- λ> productoCartesiano [[1,3],[2,5],[6,4]]

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

productoCartesiano :: [[a]] -> [[a]]

productoCartesiano [] = [[]]

productoCartesiano (xs:xss) =

[x:ys | x <- xs, ys <- productoCartesiano xss]

-- 5ª solución --

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

sumaAmigosMenores5 :: Integer -> Integer

sumaAmigosMenores5 n =

sum [x+y | (x,y) <- amigosMenores5 n]

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

amigosMenores5 n =

takeWhile (\(_,y) -> y < n) sucesionAmigos5

sucesionAmigos5 :: [(Integer,Integer)]

sucesionAmigos5 =

[(x,y) | x <- [1..],

let y = sumaDivisoresPropios5 x,

y > x,

sumaDivisoresPropios5 y == x]

sumaDivisoresPropios5 :: Integer -> Integer

sumaDivisoresPropios5 = sum . divisoresPropios5

divisoresPropios5 :: Integer -> [Integer]

divisoresPropios5 =

init

. sort

. map (product . concat)

. sequence

. map inits

. group

. primeFactors

-- 6ª solución --

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

sumaAmigosMenores6 :: Integer -> Integer

sumaAmigosMenores6 n =

sum [x+y | (x,y) <- amigosMenores6 n]

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

amigosMenores6 n =

takeWhile (\(_,y) -> y < n) sucesionAmigos6

sucesionAmigos6 :: [(Integer,Integer)]

sucesionAmigos6 =

[(x,y) | x <- [1..],

let y = sumaDivisoresPropios6 x,

y > x,

sumaDivisoresPropios6 y == x]

sumaDivisoresPropios6 :: Integer -> Integer

sumaDivisoresPropios6 =

sum

. init

. map (product . concat)

. sequence

. map inits

. group

. primeFactors

-- 7ª solución --

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

sumaAmigosMenores7 :: Integer -> Integer

sumaAmigosMenores7 n =

sum [x+y | (x,y) <- amigosMenores7 n]

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

amigosMenores7 n =

takeWhile (\(_,y) -> y < n) sucesionAmigos7

sucesionAmigos7 :: [(Integer,Integer)]

sucesionAmigos7 =

[(x,y) | x <- [1..],

let y = sumaDivisoresPropios7 x,

y > x,

sumaDivisoresPropios7 y == x]

-- Si la descomposición de x en factores primos es

-- x = p(1)^e(1) . p(2)^e(2) . .... . p(n)^e(n)

-- entonces la suma de los divisores de x es

-- p(1)^(e(1)+1) - 1 p(2)^(e(2)+1) - 1 p(n)^(e(2)+1) - 1

-- ------------------- . ------------------- ... -------------------

-- p(1)-1 p(2)-1 p(n)-1

-- Ver la demostración en http://bit.ly/2zUXZPc

sumaDivisoresPropios7 :: Integer -> Integer

sumaDivisoresPropios7 x =

product [(p^(e+1)-1) `div` (p-1) | (p,e) <- factorizacion x] - x

-- (factorizacion x) es la lista de las bases y exponentes de la

-- descomposición prima de x. Por ejemplo,

-- factorizacion 600 == [(2,3),(3,1),(5,2)]

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

factorizacion = map primeroYlongitud . group . primeFactors

-- (primeroYlongitud xs) es el par formado por el primer elemento de xs

-- y la longitud de xs. Por ejemplo,

-- primeroYlongitud [3,2,5,7] == (3,4)

primeroYlongitud :: [a] -> (a,Integer)

primeroYlongitud (x:xs) = (x, 1 + genericLength xs)

-- Comparación de eficiencia

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

-- La comparación es

-- λ> sumaAmigosMenores1 6000

-- 19026

-- (10.37 secs, 5,261,392,352 bytes)

-- λ> sumaAmigosMenores2 6000

-- 19026

-- (3.86 secs, 3,161,700,400 bytes)

-- λ> sumaAmigosMenores3 6000

-- 19026

-- (0.15 secs, 308,520,248 bytes)

-- λ> sumaAmigosMenores4 6000

-- 19026

-- (0.23 secs, 271,421,184 bytes)

-- λ> sumaAmigosMenores5 6000

-- 19026

-- (0.13 secs, 230,042,112 bytes)

-- λ> sumaAmigosMenores6 6000

-- 19026

-- (0.12 secs, 202,638,880 bytes)

-- λ> sumaAmigosMenores7 6000

-- 19026

-- (0.13 secs, 159,022,448 bytes)

-- λ> sumaAmigosMenores3 (10^5)

-- 852810

-- (4.83 secs, 10,726,377,728 bytes)

-- λ> sumaAmigosMenores4 (10^5)

-- 852810

-- (4.79 secs, 7,832,234,120 bytes)

-- λ> sumaAmigosMenores5 (10^5)

-- 852810

-- (2.79 secs, 6,837,118,464 bytes)

-- λ> sumaAmigosMenores6 (10^5)

-- 852810

-- (2.39 secs, 6,229,730,472 bytes)

-- λ> sumaAmigosMenores7 (10^5)

-- 852810

-- (2.65 secs, 5,170,949,168 bytes)

El código se encuentra en GitHub.

Sucesión de números amigos

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

Definir la lista

   sucesionAmigos :: [(Integer,Integer)]

1	sucesionAmigos :: [(Integer,Integer)]

cuyos elementos son los pares de números amigos con la primera componente menor que la segunda. Por ejemplo,

   take 4 sucesionAmigos == [(220,284),(1184,1210),(2620,2924),(5020,5564)]
   sucesionAmigos6 !! 20 == (185368,203432)

1 2	take 4 sucesionAmigos == [(220,284),(1184,1210),(2620,2924),(5020,5564)] sucesionAmigos6 !! 20 == (185368,203432)

Soluciones

import Data.List (genericLength, group, inits, nub, sort, subsequences)
import Data.Numbers.Primes (primeFactors)

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

sucesionAmigos1 :: [(Integer,Integer)]
sucesionAmigos1 =
  [(x,y) | x <- [1..],
           let y = sumaDivisoresPropios1 x,
           y > x,
           sumaDivisoresPropios1 y == x]

-- (sumaDivisoresPropios1 x) es la suma de los divisores propios de
-- x. Por ejemplo,
--    sumaDivisoresPropios1 220  ==  284
--    sumaDivisoresPropios1 284  ==  220
sumaDivisoresPropios1 :: Integer -> Integer
sumaDivisoresPropios1 = sum . divisoresPropios1

-- (divisoresPropios1 x) es la lista de los divisores propios de x. Por
-- ejemplo,
--    divisoresPropios1 220  ==  [1,2,4,5,10,11,20,22,44,55,110]
--    divisoresPropios1 284  ==  [1,2,4,71,142]
divisoresPropios1 :: Integer -> [Integer]
divisoresPropios1 x = [n | n <- [1..x-1], x `mod` n == 0]

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

sucesionAmigos2 :: [(Integer,Integer)]
sucesionAmigos2 =
  [(x,y) | x <- [1..],
           let y = sumaDivisoresPropios2 x,
           y > x,
           sumaDivisoresPropios2 y == x]

sumaDivisoresPropios2 :: Integer -> Integer
sumaDivisoresPropios2 = sum . divisoresPropios2

divisoresPropios2 :: Integer -> [Integer]
divisoresPropios2 x = filter ((== 0) . mod x) [1..x-1]

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

sucesionAmigos3 :: [(Integer,Integer)]
sucesionAmigos3 =
  [(x,y) | x <- [1..],
           let y = sumaDivisoresPropios3 x,
           y > x,
           sumaDivisoresPropios3 y == x]

sumaDivisoresPropios3 :: Integer -> Integer
sumaDivisoresPropios3 = sum . divisoresPropios3

divisoresPropios3 :: Integer -> [Integer]
divisoresPropios3 =
  init . nub . sort . map product . subsequences . primeFactors

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

sucesionAmigos4 :: [(Integer,Integer)]
sucesionAmigos4 =
  [(x,y) | x <- [1..],
           let y = sumaDivisoresPropios4 x,
           y > x,
           sumaDivisoresPropios4 y == x]

sumaDivisoresPropios4 :: Integer -> Integer
sumaDivisoresPropios4 = sum . divisoresPropios4

divisoresPropios4 :: Integer -> [Integer]
divisoresPropios4 =
  init
  . sort
  . map (product . concat)
  . productoCartesiano
  . map inits
  . group
  . primeFactors

-- (productoCartesiano xss) es el producto cartesiano de los conjuntos
-- xss. Por ejemplo,
--    λ> productoCartesiano [[1,3],[2,5],[6,4]]
--    [[1,2,6],[1,2,4],[1,5,6],[1,5,4],[3,2,6],[3,2,4],[3,5,6],[3,5,4]]
productoCartesiano :: [[a]] -> [[a]]
productoCartesiano []       = [[]]
productoCartesiano (xs:xss) =
  [x:ys | x <- xs, ys <- productoCartesiano xss]

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

sucesionAmigos5 :: [(Integer,Integer)]
sucesionAmigos5 =
  [(x,y) | x <- [1..],
           let y = sumaDivisoresPropios5 x,
           y > x,
           sumaDivisoresPropios5 y == x]

sumaDivisoresPropios5 :: Integer -> Integer
sumaDivisoresPropios5 = sum . divisoresPropios5

divisoresPropios5 :: Integer -> [Integer]
divisoresPropios5 =
  init
  . sort
  . map (product . concat)
  . sequence
  . map inits
  . group
  . primeFactors

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

sucesionAmigos6 :: [(Integer,Integer)]
sucesionAmigos6 =
  [(x,y) | x <- [1..],
           let y = sumaDivisoresPropios6 x,
           y > x,
           sumaDivisoresPropios6 y == x]

sumaDivisoresPropios6 :: Integer -> Integer
sumaDivisoresPropios6 =
  sum
  . init
  . map (product . concat)
  . sequence
  . map inits
  . group
  . primeFactors

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

sucesionAmigos7 :: [(Integer,Integer)]
sucesionAmigos7 =
  [(x,y) | x <- [1..],
           let y = sumaDivisoresPropios7 x,
           y > x,
           sumaDivisoresPropios7 y == x]

-- Si la descomposición de x en factores primos es
--    x = p(1)^e(1) . p(2)^e(2) . .... . p(n)^e(n)
-- entonces la suma de los divisores de x es
--    p(1)^(e(1)+1) - 1     p(2)^(e(2)+1) - 1       p(n)^(e(2)+1) - 1
--   ------------------- . ------------------- ... -------------------
--        p(1)-1                p(2)-1                  p(n)-1
-- Ver la demostración en http://bit.ly/2zUXZPc

sumaDivisoresPropios7 :: Integer -> Integer
sumaDivisoresPropios7 x =
  product [(p^(e+1)-1) `div` (p-1) | (p,e) <- factorizacion x] - x

-- (factorizacion x) es la lista de las bases y exponentes de la
-- descomposición prima de x. Por ejemplo,
--    factorizacion 600  ==  [(2,3),(3,1),(5,2)]
factorizacion :: Integer -> [(Integer,Integer)]
factorizacion = map primeroYlongitud . group . primeFactors

-- (primeroYlongitud xs) es el par formado por el primer elemento de xs
-- y la longitud de xs. Por ejemplo,
--    primeroYlongitud [3,2,5,7] == (3,4)
primeroYlongitud :: [a] -> (a,Integer)
primeroYlongitud (x:xs) = (x, 1 + genericLength xs)

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

-- La comparación es
--    λ> take 4 sucesionAmigos1
--    [(220,284),(1184,1210),(2620,2924),(5020,5564)]
--    (6.00 secs, 3,413,777,560 bytes)
--    λ> take 4 sucesionAmigos2
--    [(220,284),(1184,1210),(2620,2924),(5020,5564)]
--    (2.38 secs, 2,052,151,800 bytes)
--    λ> take 4 sucesionAmigos3
--    [(220,284),(1184,1210),(2620,2924),(5020,5564)]
--    (0.14 secs, 235,238,864 bytes)
--    λ> take 4 sucesionAmigos4
--    [(220,284),(1184,1210),(2620,2924),(5020,5564)]
--    (0.20 secs, 208,315,832 bytes)
--    λ> take 4 sucesionAmigos5
--    [(220,284),(1184,1210),(2620,2924),(5020,5564)]
--    (0.09 secs, 176,149,160 bytes)
--    λ> take 4 sucesionAmigos6
--    [(220,284),(1184,1210),(2620,2924),(5020,5564)]
--    (0.07 secs, 154,686,728 bytes)
--    λ> take 4 sucesionAmigos7
--    [(220,284),(1184,1210),(2620,2924),(5020,5564)]
--    (0.12 secs, 120,826,648 bytes)
--
--    λ> sucesionAmigos3 !! 10
--    (67095,71145)
--    (3.52 secs, 6,749,059,064 bytes)
--    λ> sucesionAmigos4 !! 10
--    (67095,71145)
--    (3.11 secs, 4,951,018,904 bytes)
--    λ> sucesionAmigos5 !! 10
--    (67095,71145)
--    (1.69 secs, 4,294,457,320 bytes)
--    λ> sucesionAmigos6 !! 10
--    (67095,71145)
--    (1.43 secs, 3,889,045,760 bytes)
--    λ> sucesionAmigos7 !! 10
--    (67095,71145)
--    (1.63 secs, 3,191,073,224 bytes)
--
--    λ> sucesionAmigos5 !! 12
--    (79750,88730)
--    (2.13 secs, 5,312,053,312 bytes)
--    λ> sucesionAmigos6 !! 12
--    (79750,88730)
--    (1.78 secs, 4,820,560,920 bytes)
--    λ> sucesionAmigos7 !! 12
--    (79750,88730)
--    (2.11 secs, 3,971,113,184 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

217

218

219

220

import Data.List (genericLength, group, inits, nub, sort, subsequences)

import Data.Numbers.Primes (primeFactors)

-- 1ª solución --

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

sucesionAmigos1 :: [(Integer,Integer)]

sucesionAmigos1 =

[(x,y) | x <- [1..],

let y = sumaDivisoresPropios1 x,

y > x,

sumaDivisoresPropios1 y == x]

-- (sumaDivisoresPropios1 x) es la suma de los divisores propios de

-- x. Por ejemplo,

-- sumaDivisoresPropios1 220 == 284

-- sumaDivisoresPropios1 284 == 220

sumaDivisoresPropios1 :: Integer -> Integer

sumaDivisoresPropios1 = sum . divisoresPropios1

-- (divisoresPropios1 x) es la lista de los divisores propios de x. Por

-- ejemplo,

-- divisoresPropios1 220 == [1,2,4,5,10,11,20,22,44,55,110]

-- divisoresPropios1 284 == [1,2,4,71,142]

divisoresPropios1 :: Integer -> [Integer]

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

-- 2ª solución --

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

sucesionAmigos2 :: [(Integer,Integer)]

sucesionAmigos2 =

[(x,y) | x <- [1..],

let y = sumaDivisoresPropios2 x,

y > x,

sumaDivisoresPropios2 y == x]

sumaDivisoresPropios2 :: Integer -> Integer

sumaDivisoresPropios2 = sum . divisoresPropios2

divisoresPropios2 :: Integer -> [Integer]

divisoresPropios2 x = filter ((== 0) . mod x) [1..x-1]

-- 3ª solución --

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

sucesionAmigos3 :: [(Integer,Integer)]

sucesionAmigos3 =

[(x,y) | x <- [1..],

let y = sumaDivisoresPropios3 x,

y > x,

sumaDivisoresPropios3 y == x]

sumaDivisoresPropios3 :: Integer -> Integer

sumaDivisoresPropios3 = sum . divisoresPropios3

divisoresPropios3 :: Integer -> [Integer]

divisoresPropios3 =

init . nub . sort . map product . subsequences . primeFactors

-- 4ª solución --

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

sucesionAmigos4 :: [(Integer,Integer)]

sucesionAmigos4 =

[(x,y) | x <- [1..],

let y = sumaDivisoresPropios4 x,

y > x,

sumaDivisoresPropios4 y == x]

sumaDivisoresPropios4 :: Integer -> Integer

sumaDivisoresPropios4 = sum . divisoresPropios4

divisoresPropios4 :: Integer -> [Integer]

divisoresPropios4 =

init

. sort

. map (product . concat)

. productoCartesiano

. map inits

. group

. primeFactors

-- (productoCartesiano xss) es el producto cartesiano de los conjuntos

-- xss. Por ejemplo,

-- λ> productoCartesiano [[1,3],[2,5],[6,4]]

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

productoCartesiano :: [[a]] -> [[a]]

productoCartesiano [] = [[]]

productoCartesiano (xs:xss) =

[x:ys | x <- xs, ys <- productoCartesiano xss]

-- 5ª solución --

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

sucesionAmigos5 :: [(Integer,Integer)]

sucesionAmigos5 =

[(x,y) | x <- [1..],

let y = sumaDivisoresPropios5 x,

y > x,

sumaDivisoresPropios5 y == x]

sumaDivisoresPropios5 :: Integer -> Integer

sumaDivisoresPropios5 = sum . divisoresPropios5

divisoresPropios5 :: Integer -> [Integer]

divisoresPropios5 =

init

. sort

. map (product . concat)

. sequence

. map inits

. group

. primeFactors

-- 6ª solución --

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

sucesionAmigos6 :: [(Integer,Integer)]

sucesionAmigos6 =

[(x,y) | x <- [1..],

let y = sumaDivisoresPropios6 x,

y > x,

sumaDivisoresPropios6 y == x]

sumaDivisoresPropios6 :: Integer -> Integer

sumaDivisoresPropios6 =

sum

. init

. map (product . concat)

. sequence

. map inits

. group

. primeFactors

-- 7ª solución --

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

sucesionAmigos7 :: [(Integer,Integer)]

sucesionAmigos7 =

[(x,y) | x <- [1..],

let y = sumaDivisoresPropios7 x,

y > x,

sumaDivisoresPropios7 y == x]

-- Si la descomposición de x en factores primos es

-- x = p(1)^e(1) . p(2)^e(2) . .... . p(n)^e(n)

-- entonces la suma de los divisores de x es

-- p(1)^(e(1)+1) - 1 p(2)^(e(2)+1) - 1 p(n)^(e(2)+1) - 1

-- ------------------- . ------------------- ... -------------------

-- p(1)-1 p(2)-1 p(n)-1

-- Ver la demostración en http://bit.ly/2zUXZPc

sumaDivisoresPropios7 :: Integer -> Integer

sumaDivisoresPropios7 x =

product [(p^(e+1)-1) `div` (p-1) | (p,e) <- factorizacion x] - x

-- (factorizacion x) es la lista de las bases y exponentes de la

-- descomposición prima de x. Por ejemplo,

-- factorizacion 600 == [(2,3),(3,1),(5,2)]

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

factorizacion = map primeroYlongitud . group . primeFactors

-- (primeroYlongitud xs) es el par formado por el primer elemento de xs

-- y la longitud de xs. Por ejemplo,

-- primeroYlongitud [3,2,5,7] == (3,4)

primeroYlongitud :: [a] -> (a,Integer)

primeroYlongitud (x:xs) = (x, 1 + genericLength xs)

-- Comparación de eficiencia

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

-- La comparación es

-- λ> take 4 sucesionAmigos1

-- [(220,284),(1184,1210),(2620,2924),(5020,5564)]

-- (6.00 secs, 3,413,777,560 bytes)

-- λ> take 4 sucesionAmigos2

-- [(220,284),(1184,1210),(2620,2924),(5020,5564)]

-- (2.38 secs, 2,052,151,800 bytes)

-- λ> take 4 sucesionAmigos3

-- [(220,284),(1184,1210),(2620,2924),(5020,5564)]

-- (0.14 secs, 235,238,864 bytes)

-- λ> take 4 sucesionAmigos4

-- [(220,284),(1184,1210),(2620,2924),(5020,5564)]

-- (0.20 secs, 208,315,832 bytes)

-- λ> take 4 sucesionAmigos5

-- [(220,284),(1184,1210),(2620,2924),(5020,5564)]

-- (0.09 secs, 176,149,160 bytes)

-- λ> take 4 sucesionAmigos6

-- [(220,284),(1184,1210),(2620,2924),(5020,5564)]

-- (0.07 secs, 154,686,728 bytes)

-- λ> take 4 sucesionAmigos7

-- [(220,284),(1184,1210),(2620,2924),(5020,5564)]

-- (0.12 secs, 120,826,648 bytes)

-- λ> sucesionAmigos3 !! 10

-- (67095,71145)

-- (3.52 secs, 6,749,059,064 bytes)

-- λ> sucesionAmigos4 !! 10

-- (67095,71145)

-- (3.11 secs, 4,951,018,904 bytes)

-- λ> sucesionAmigos5 !! 10

-- (67095,71145)

-- (1.69 secs, 4,294,457,320 bytes)

-- λ> sucesionAmigos6 !! 10

-- (67095,71145)

-- (1.43 secs, 3,889,045,760 bytes)

-- λ> sucesionAmigos7 !! 10

-- (67095,71145)

-- (1.63 secs, 3,191,073,224 bytes)

-- λ> sucesionAmigos5 !! 12

-- (79750,88730)

-- (2.13 secs, 5,312,053,312 bytes)

-- λ> sucesionAmigos6 !! 12

-- (79750,88730)

-- (1.78 secs, 4,820,560,920 bytes)

-- λ> sucesionAmigos7 !! 12

-- (79750,88730)

-- (2.11 secs, 3,971,113,184 bytes)

El código se encuentra en GitHub.

Números amigos

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

Definir la función

   amigos :: Integer -> Integer -> Bool

1	amigos :: Integer -> Integer -> Bool

tal que (amigos x y) se verifica si los números x e y son amigos. Por ejemplo,

   amigos 220 284 == True
   amigos 220 23  == False
   amigos 42262694537514864075544955198125 42405817271188606697466971841875 == True

amigos 220 284 == True

amigos 220 23 == False

amigos 42262694537514864075544955198125 42405817271188606697466971841875 == True

Soluciones

import Data.List (genericLength, group, inits, nub, sort, subsequences)
import Data.Numbers.Primes (primeFactors)

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

amigos1 :: Integer -> Integer -> Bool
amigos1 x y = sumaDivisoresPropios1 x == y &&
              sumaDivisoresPropios1 y == x

-- (sumaDivisoresPropios1 x) es la suma de los divisores propios de
-- x. Por ejemplo,
--    sumaDivisoresPropios1 220  ==  284
--    sumaDivisoresPropios1 284  ==  220
sumaDivisoresPropios1 :: Integer -> Integer
sumaDivisoresPropios1 = sum . divisoresPropios1

-- (divisoresPropios1 x) es la lista de los divisores propios de x. Por
-- ejemplo,
--    divisoresPropios1 220  ==  [1,2,4,5,10,11,20,22,44,55,110]
--    divisoresPropios1 284  ==  [1,2,4,71,142]
divisoresPropios1 :: Integer -> [Integer]
divisoresPropios1 x = [n | n <- [1..x-1], x `mod` n == 0]

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

amigos2 :: Integer -> Integer -> Bool
amigos2 x y = sumaDivisoresPropios2 x == y &&
              sumaDivisoresPropios2 y == x

sumaDivisoresPropios2 :: Integer -> Integer
sumaDivisoresPropios2 = sum . divisoresPropios2

divisoresPropios2 :: Integer -> [Integer]
divisoresPropios2 x = filter ((== 0) . mod x) [1..x-1]

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

amigos3 :: Integer -> Integer -> Bool
amigos3 x y = sumaDivisoresPropios3 x == y &&
              sumaDivisoresPropios3 y == x

sumaDivisoresPropios3 :: Integer -> Integer
sumaDivisoresPropios3 = sum . divisoresPropios3

divisoresPropios3 :: Integer -> [Integer]
divisoresPropios3 =
  init . nub . sort . map product . subsequences . primeFactors

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

amigos4 :: Integer -> Integer -> Bool
amigos4 x y = sumaDivisoresPropios4 x == y &&
              sumaDivisoresPropios4 y == x

sumaDivisoresPropios4 :: Integer -> Integer
sumaDivisoresPropios4 = sum . divisoresPropios4

divisoresPropios4 :: Integer -> [Integer]
divisoresPropios4 =
  init
  . sort
  . map (product . concat)
  . productoCartesiano
  . map inits
  . group
  . primeFactors

-- (productoCartesiano xss) es el producto cartesiano de los conjuntos
-- xss. Por ejemplo,
--    λ> productoCartesiano [[1,3],[2,5],[6,4]]
--    [[1,2,6],[1,2,4],[1,5,6],[1,5,4],[3,2,6],[3,2,4],[3,5,6],[3,5,4]]
productoCartesiano :: [[a]] -> [[a]]
productoCartesiano []       = [[]]
productoCartesiano (xs:xss) =
  [x:ys | x <- xs, ys <- productoCartesiano xss]

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

amigos5 :: Integer -> Integer -> Bool
amigos5 x y = sumaDivisoresPropios5 x == y &&
              sumaDivisoresPropios5 y == x

sumaDivisoresPropios5 :: Integer -> Integer
sumaDivisoresPropios5 =
  sum . divisoresPropios5

divisoresPropios5 :: Integer -> [Integer]
divisoresPropios5 =
  init
  . sort
  . map (product . concat)
  . sequence
  . map inits
  . group
  . primeFactors

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

amigos6 :: Integer -> Integer -> Bool
amigos6 x y = sumaDivisoresPropios6 x == y &&
              sumaDivisoresPropios6 y == x

sumaDivisoresPropios6 :: Integer -> Integer
sumaDivisoresPropios6 =
  sum
  . init
  . map (product . concat)
  . sequence
  . map inits
  . group
  . primeFactors

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

amigos7 :: Integer -> Integer -> Bool
amigos7 x y = sumaDivisoresPropios7 x == y &&
              sumaDivisoresPropios7 y == x

-- Si la descomposición de x en factores primos es
--    x = p(1)^e(1) . p(2)^e(2) . .... . p(n)^e(n)
-- entonces la suma de los divisores de x es
--    p(1)^(e(1)+1) - 1     p(2)^(e(2)+1) - 1       p(n)^(e(2)+1) - 1
--   ------------------- . ------------------- ... -------------------
--        p(1)-1                p(2)-1                  p(n)-1
-- Ver la demostración en http://bit.ly/2zUXZPc

-- (sumaDivisoresPropios7 x) es la suma de los divisores propios de
-- x. Por ejemplo,
--    sumaDivisoresPropios7 220  ==  284
--    sumaDivisoresPropios7 284  ==  220
sumaDivisoresPropios7 :: Integer -> Integer
sumaDivisoresPropios7 x =
  product [(p^(e+1)-1) `div` (p-1) | (p,e) <- factorizacion x] - x

-- (factorizacion x) es la lista de las bases y exponentes de la
-- descomposición prima de x. Por ejemplo,
--    factorizacion 600  ==  [(2,3),(3,1),(5,2)]
factorizacion :: Integer -> [(Integer,Integer)]
factorizacion = map primeroYlongitud . group . primeFactors

-- (primeroYlongitud xs) es el par formado por el primer elemento de xs
-- y la longitud de xs. Por ejemplo,
--    primeroYlongitud [3,2,5,7] == (3,4)
primeroYlongitud :: [a] -> (a,Integer)
primeroYlongitud (x:xs) = (x, 1 + genericLength xs)

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

-- La comparación es
--    λ> amigos1 2803580 3716164
--    True
--    (2.27 secs, 1,304,055,864 bytes)
--    λ> amigos2 2803580 3716164
--    True
--    (0.81 secs, 782,478,584 bytes)
--    λ> amigos3 2803580 3716164
--    True
--    (0.01 secs, 383,888 bytes)
--    λ> amigos4 2803580 3716164
--    True
--    (0.01 secs, 461,376 bytes)
--    λ> amigos5 2803580 3716164
--    True
--    (0.00 secs, 412,560 bytes)
--    λ> amigos6 2803580 3716164
--    True
--    (0.00 secs, 387,816 bytes)
--    λ> amigos7 2803580 3716164
--    True
--    (0.01 secs, 339,008 bytes)
--
--    λ> amigos2 5864660 7489324
--    True
--    (1.74 secs, 1,602,582,592 bytes)
--    λ> amigos3 5864660 7489324
--    True
--    (0.00 secs, 277,056 bytes)
--    λ> amigos4 5864660 7489324
--    True
--    (0.01 secs, 354,872 bytes)
--    λ> amigos5 5864660 7489324
--    True
--    (0.01 secs, 305,792 bytes)
--    λ> amigos6 5864660 7489324
--    True
--    (0.00 secs, 281,528 bytes)
--    λ> amigos7 5864660 7489324
--    True
--    (0.01 secs, 237,176 bytes)
--
--    λ> amigos3 42262694537514864075544955198125 42405817271188606697466971841875
--    True
--    (107.54 secs, 5,594,306,392 bytes)
--    λ> amigos4 42262694537514864075544955198125 42405817271188606697466971841875
--    True
--    (1.03 secs, 942,530,824 bytes)
--    λ> amigos5 42262694537514864075544955198125 42405817271188606697466971841875
--    True
--    (0.51 secs, 591,144,304 bytes)
--    λ> amigos6 42262694537514864075544955198125 42405817271188606697466971841875
--    True
--    (0.26 secs, 379,534,608 bytes)
--    λ> amigos7 42262694537514864075544955198125 42405817271188606697466971841875
--    True
--    (0.05 secs, 25,635,464 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

import Data.List (genericLength, group, inits, nub, sort, subsequences)

import Data.Numbers.Primes (primeFactors)

-- 1ª solución --

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

amigos1 :: Integer -> Integer -> Bool

amigos1 x y = sumaDivisoresPropios1 x == y &&

sumaDivisoresPropios1 y == x

-- (sumaDivisoresPropios1 x) es la suma de los divisores propios de

-- x. Por ejemplo,

-- sumaDivisoresPropios1 220 == 284

-- sumaDivisoresPropios1 284 == 220

sumaDivisoresPropios1 :: Integer -> Integer

sumaDivisoresPropios1 = sum . divisoresPropios1

-- (divisoresPropios1 x) es la lista de los divisores propios de x. Por

-- ejemplo,

-- divisoresPropios1 220 == [1,2,4,5,10,11,20,22,44,55,110]

-- divisoresPropios1 284 == [1,2,4,71,142]

divisoresPropios1 :: Integer -> [Integer]

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

-- 2ª solución --

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

amigos2 :: Integer -> Integer -> Bool

amigos2 x y = sumaDivisoresPropios2 x == y &&

sumaDivisoresPropios2 y == x

sumaDivisoresPropios2 :: Integer -> Integer

sumaDivisoresPropios2 = sum . divisoresPropios2

divisoresPropios2 :: Integer -> [Integer]

divisoresPropios2 x = filter ((== 0) . mod x) [1..x-1]

-- 3ª solución --

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

amigos3 :: Integer -> Integer -> Bool

amigos3 x y = sumaDivisoresPropios3 x == y &&

sumaDivisoresPropios3 y == x

sumaDivisoresPropios3 :: Integer -> Integer

sumaDivisoresPropios3 = sum . divisoresPropios3

divisoresPropios3 :: Integer -> [Integer]

divisoresPropios3 =

init . nub . sort . map product . subsequences . primeFactors

-- 4ª solución --

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

amigos4 :: Integer -> Integer -> Bool

amigos4 x y = sumaDivisoresPropios4 x == y &&

sumaDivisoresPropios4 y == x

sumaDivisoresPropios4 :: Integer -> Integer

sumaDivisoresPropios4 = sum . divisoresPropios4

divisoresPropios4 :: Integer -> [Integer]

divisoresPropios4 =

init

. sort

. map (product . concat)

. productoCartesiano

. map inits

. group

. primeFactors

-- (productoCartesiano xss) es el producto cartesiano de los conjuntos

-- xss. Por ejemplo,

-- λ> productoCartesiano [[1,3],[2,5],[6,4]]

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

productoCartesiano :: [[a]] -> [[a]]

productoCartesiano [] = [[]]

productoCartesiano (xs:xss) =

[x:ys | x <- xs, ys <- productoCartesiano xss]

-- 5ª solución --

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

amigos5 :: Integer -> Integer -> Bool

amigos5 x y = sumaDivisoresPropios5 x == y &&

sumaDivisoresPropios5 y == x

sumaDivisoresPropios5 :: Integer -> Integer

sumaDivisoresPropios5 =

sum . divisoresPropios5

divisoresPropios5 :: Integer -> [Integer]

divisoresPropios5 =

init

. sort

. map (product . concat)

. sequence

. map inits

. group

. primeFactors

-- 6ª solución --

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

amigos6 :: Integer -> Integer -> Bool

amigos6 x y = sumaDivisoresPropios6 x == y &&

sumaDivisoresPropios6 y == x

sumaDivisoresPropios6 :: Integer -> Integer

sumaDivisoresPropios6 =

sum

. init

. map (product . concat)

. sequence

. map inits

. group

. primeFactors

-- 7ª solución --

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

amigos7 :: Integer -> Integer -> Bool

amigos7 x y = sumaDivisoresPropios7 x == y &&

sumaDivisoresPropios7 y == x

-- Si la descomposición de x en factores primos es

-- x = p(1)^e(1) . p(2)^e(2) . .... . p(n)^e(n)

-- entonces la suma de los divisores de x es

-- p(1)^(e(1)+1) - 1 p(2)^(e(2)+1) - 1 p(n)^(e(2)+1) - 1

-- ------------------- . ------------------- ... -------------------

-- p(1)-1 p(2)-1 p(n)-1

-- Ver la demostración en http://bit.ly/2zUXZPc

-- (sumaDivisoresPropios7 x) es la suma de los divisores propios de

-- x. Por ejemplo,

-- sumaDivisoresPropios7 220 == 284

-- sumaDivisoresPropios7 284 == 220

sumaDivisoresPropios7 :: Integer -> Integer

sumaDivisoresPropios7 x =

product [(p^(e+1)-1) `div` (p-1) | (p,e) <- factorizacion x] - x

-- (factorizacion x) es la lista de las bases y exponentes de la

-- descomposición prima de x. Por ejemplo,

-- factorizacion 600 == [(2,3),(3,1),(5,2)]

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

factorizacion = map primeroYlongitud . group . primeFactors

-- (primeroYlongitud xs) es el par formado por el primer elemento de xs

-- y la longitud de xs. Por ejemplo,

-- primeroYlongitud [3,2,5,7] == (3,4)

primeroYlongitud :: [a] -> (a,Integer)

primeroYlongitud (x:xs) = (x, 1 + genericLength xs)

-- Comparación de eficiencia

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

-- La comparación es

-- λ> amigos1 2803580 3716164

-- True

-- (2.27 secs, 1,304,055,864 bytes)

-- λ> amigos2 2803580 3716164

-- True

-- (0.81 secs, 782,478,584 bytes)

-- λ> amigos3 2803580 3716164

-- True

-- (0.01 secs, 383,888 bytes)

-- λ> amigos4 2803580 3716164

-- True

-- (0.01 secs, 461,376 bytes)

-- λ> amigos5 2803580 3716164

-- True

-- (0.00 secs, 412,560 bytes)

-- λ> amigos6 2803580 3716164

-- True

-- (0.00 secs, 387,816 bytes)

-- λ> amigos7 2803580 3716164

-- True

-- (0.01 secs, 339,008 bytes)

-- λ> amigos2 5864660 7489324

-- True

-- (1.74 secs, 1,602,582,592 bytes)

-- λ> amigos3 5864660 7489324

-- True

-- (0.00 secs, 277,056 bytes)

-- λ> amigos4 5864660 7489324

-- True

-- (0.01 secs, 354,872 bytes)

-- λ> amigos5 5864660 7489324

-- True

-- (0.01 secs, 305,792 bytes)

-- λ> amigos6 5864660 7489324

-- True

-- (0.00 secs, 281,528 bytes)

-- λ> amigos7 5864660 7489324

-- True

-- (0.01 secs, 237,176 bytes)

-- λ> amigos3 42262694537514864075544955198125 42405817271188606697466971841875

-- True

-- (107.54 secs, 5,594,306,392 bytes)

-- λ> amigos4 42262694537514864075544955198125 42405817271188606697466971841875

-- True

-- (1.03 secs, 942,530,824 bytes)

-- λ> amigos5 42262694537514864075544955198125 42405817271188606697466971841875

-- True

-- (0.51 secs, 591,144,304 bytes)

-- λ> amigos6 42262694537514864075544955198125 42405817271188606697466971841875

-- True

-- (0.26 secs, 379,534,608 bytes)

-- λ> amigos7 42262694537514864075544955198125 42405817271188606697466971841875

-- True

-- (0.05 secs, 25,635,464 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.

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.

Suma de cadenas

PorJosé A. Alonso 27-enero-202223-febrero-2022

Definir la función

   sumaCadenas :: String -> String -> String

1	sumaCadenas :: String -> String -> String

tal que (sumaCadenas xs ys) es la cadena formada por el número entero que es la suma de los números enteros cuyas cadenas que lo representan son xs e ys; además, se supone que la cadena vacía representa al cero. Por ejemplo,

   sumaCadenas "2"   "6"  == "8"
   sumaCadenas "14"  "2"  == "16"
   sumaCadenas "14"  "-5" == "9"
   sumaCadenas "-14" "-5" == "-19"
   sumaCadenas "5"   "-5" == "0"
   sumaCadenas ""    "5"  == "5"
   sumaCadenas "6"   ""   == "6"
   sumaCadenas ""    ""   == "0"

sumaCadenas "2" "6" == "8"

sumaCadenas "14" "2" == "16"

sumaCadenas "14" "-5" == "9"

sumaCadenas "-14" "-5" == "-19"

sumaCadenas "5" "-5" == "0"

sumaCadenas "" "5" == "5"

sumaCadenas "6" "" == "6"

sumaCadenas "" "" == "0"

Soluciones

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

sumaCadenas1 :: String -> String -> String
sumaCadenas1 xs ys =
  show (sum (map read (filter (not . null) [xs, ys])))

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

sumaCadenas2 :: String -> String -> String
sumaCadenas2 =
  ((show . sum . map read . filter (not . null)) .) . (. return) . (:)

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

sumaCadenas3 :: String -> String -> String
sumaCadenas3 "" "" = "0"
sumaCadenas3 "" ys = ys
sumaCadenas3 xs "" = xs
sumaCadenas3 xs ys = show (read xs + read ys)

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

sumaCadenas4 :: String -> String -> String
sumaCadenas4 xs ys = show (numero xs + numero ys)

-- (numero xs) es el número entero representado por la cadena xs
-- suponiendo que la cadena vacía representa al cero.. Por ejemplo,
--    numero "12"   ==  12
--    numero "-12"  ==  -12
--    numero "0"    ==  0
--    numero ""     ==  0
numero :: String -> Int
numero "" = 0
numero xs = read xs

-- 1ª solución

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

sumaCadenas1 :: String -> String -> String

sumaCadenas1 xs ys =

show (sum (map read (filter (not . null) [xs, ys])))

-- 2ª solución

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

sumaCadenas2 :: String -> String -> String

sumaCadenas2 =

((show . sum . map read . filter (not . null)) .) . (. return) . (:)

-- 3ª solución

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

sumaCadenas3 :: String -> String -> String

sumaCadenas3 "" "" = "0"

sumaCadenas3 "" ys = ys

sumaCadenas3 xs "" = xs

sumaCadenas3 xs ys = show (read xs + read ys)

-- 4ª solución

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

sumaCadenas4 :: String -> String -> String

sumaCadenas4 xs ys = show (numero xs + numero ys)

-- (numero xs) es el número entero representado por la cadena xs

-- suponiendo que la cadena vacía representa al cero.. Por ejemplo,

-- numero "12" == 12

-- numero "-12" == -12

-- numero "0" == 0

-- numero "" == 0

numero :: String -> Int

numero "" = 0

numero xs = read xs

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)

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)

Soluciones

Nuevas 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