elem – Página 2 – Exercitium

El problema de las celebridades

PorJosé A. Alonso 15-mayo-201822-mayo-2018

La celebridad de una reunión es una persona al que todos conocen pero que no conoce a nadie. Por ejemplo, si en la reunión hay tres personas tales que la 1 conoce a la 3 y la 2 conoce a la 1 y a la 3, entonces la celebridad de la reunión es la 3.

La relación de conocimiento se puede representar mediante una lista de pares (x,y) indicando que x conoce a y. Por ejemplo, la reunión anterior se puede representar por [(1,3),(2,1),(2,3)].

Definir la función

   celebridad :: Ord a => [(a,a)] -> Maybe a

1	celebridad :: Ord a => [(a,a)] -> Maybe a

tal que (celebridad r) es el justo la celebridad de r, si en r hay una celebridad y Nothing, en caso contrario. Por ejemplo,

   celebridad [(1,3),(2,1),(2,3)]            ==  Just 3
   celebridad [(1,3),(2,1),(3,2)]            ==  Nothing
   celebridad [(1,3),(2,1),(2,3),(3,1)]      ==  Nothing
   celebridad [(x,1) | x <- [2..10^6]]       ==  Just 1
   celebridad [(x,10^6) | x <- [1..10^6-1]]  ==  Just 1000000

celebridad [(1,3),(2,1),(2,3)] == Just 3

celebridad [(1,3),(2,1),(3,2)] == Nothing

celebridad [(1,3),(2,1),(2,3),(3,1)] == Nothing

celebridad [(x,1) | x <- [2..10^6]] == Just 1

celebridad [(x,10^6) | x <- [1..10^6-1]] == Just 1000000

Soluciones

import Data.List (delete, nub)
import Data.Maybe (listToMaybe)
import qualified Data.Set as S

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

celebridad1 :: Ord a => [(a,a)] -> Maybe a
celebridad1 r =
  listToMaybe [x | x <- personas r, esCelebridad r x]

personas :: Ord a => [(a,a)] -> [a]
personas r =
  nub (map fst r ++ map snd r)

esCelebridad :: Ord a => [(a,a)] -> a -> Bool
esCelebridad r x =
     [y | y <- ys, (y,x) `elem` r] == ys
  && null [y | y <- ys, (x,y) `elem` r]
  where ys = delete x (personas r)

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

celebridad2 :: Ord a => [(a,a)] -> Maybe a
celebridad2 r =
  listToMaybe [x | x <- personas2 c, esCelebridad2 c x]
  where c = S.fromList r

--    λ> personas2 (S.fromList [(1,3),(2,1),(2,3)])
--    [1,2,3]
personas2 :: Ord a => S.Set (a,a) -> [a]
personas2 c =
  S.toList (S.map fst c `S.union` S.map snd c)

esCelebridad2 :: Ord a => S.Set (a,a) -> a -> Bool
esCelebridad2 c x = 
      [y | y <- ys, (y,x) `S.member` c] == ys
   && null [y | y <- ys, (x,y) `S.member` c]
   where ys = delete x (personas2 c)

-- 3ª definición
-- =============

celebridad3 :: Ord a => [(a,a)] -> Maybe a
celebridad3 r
  | S.null candidatos = Nothing
  | esCelebridad      = Just candidato
  | otherwise         = Nothing
  where
    conjunto          = S.fromList r
    dominio           = S.map fst conjunto
    rango             = S.map snd conjunto
    total             = dominio `S.union` rango
    candidatos        = rango `S.difference` dominio
    candidato         = S.findMin candidatos
    noCandidatos      = S.delete candidato total
    esCelebridad      =
      S.filter (\x -> (x,candidato) `S.member` conjunto) total == noCandidatos
     
-- Comparación de eficiencia
-- =========================

--    λ> celebridad1 [(x,1) | x <- [2..300]]
--    Just 1
--    (2.70 secs, 38,763,888 bytes)
--    λ> celebridad2 [(x,1) | x <- [2..300]]
--    Just 1
--    (0.01 secs, 0 bytes)
-- 
--    λ> celebridad2 [(x,1000) | x <- [1..999]]
--    Just 1000
--    (2.23 secs, 483,704,224 bytes)
--    λ> celebridad3 [(x,1000) | x <- [1..999]]
--    Just 1000
--    (0.02 secs, 0 bytes)
-- 
--    λ> celebridad3 [(x,10^6) | x <- [1..10^6-1]]
--    Just 1000000
--    (9.56 secs, 1,572,841,088 bytes)
--    λ> celebridad3 [(x,1) | x <- [2..10^6]]
--    Just 1
--    (6.17 secs, 696,513,320 bytes)

import Data.List (delete, nub)

import Data.Maybe (listToMaybe)

import qualified Data.Set as S

-- 1ª solución

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

celebridad1 :: Ord a => [(a,a)] -> Maybe a

celebridad1 r =

listToMaybe [x | x <- personas r, esCelebridad r x]

personas :: Ord a => [(a,a)] -> [a]

personas r =

nub (map fst r ++ map snd r)

esCelebridad :: Ord a => [(a,a)] -> a -> Bool

esCelebridad r x =

[y | y <- ys, (y,x) `elem` r] == ys

&& null [y | y <- ys, (x,y) `elem` r]

where ys = delete x (personas r)

-- 2ª solución

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

celebridad2 :: Ord a => [(a,a)] -> Maybe a

celebridad2 r =

listToMaybe [x | x <- personas2 c, esCelebridad2 c x]

where c = S.fromList r

-- λ> personas2 (S.fromList [(1,3),(2,1),(2,3)])

-- [1,2,3]

personas2 :: Ord a => S.Set (a,a) -> [a]

personas2 c =

S.toList (S.map fst c `S.union` S.map snd c)

esCelebridad2 :: Ord a => S.Set (a,a) -> a -> Bool

esCelebridad2 c x =

[y | y <- ys, (y,x) `S.member` c] == ys

&& null [y | y <- ys, (x,y) `S.member` c]

where ys = delete x (personas2 c)

-- 3ª definición

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

celebridad3 :: Ord a => [(a,a)] -> Maybe a

celebridad3 r

| S.null candidatos = Nothing

| esCelebridad = Just candidato

| otherwise = Nothing

where

conjunto = S.fromList r

dominio = S.map fst conjunto

rango = S.map snd conjunto

total = dominio `S.union` rango

candidatos = rango `S.difference` dominio

candidato = S.findMin candidatos

noCandidatos = S.delete candidato total

esCelebridad =

S.filter (\x -> (x,candidato) `S.member` conjunto) total == noCandidatos

-- Comparación de eficiencia

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

-- λ> celebridad1 [(x,1) | x <- [2..300]]

-- Just 1

-- (2.70 secs, 38,763,888 bytes)

-- λ> celebridad2 [(x,1) | x <- [2..300]]

-- Just 1

-- (0.01 secs, 0 bytes)

-- λ> celebridad2 [(x,1000) | x <- [1..999]]

-- Just 1000

-- (2.23 secs, 483,704,224 bytes)

-- λ> celebridad3 [(x,1000) | x <- [1..999]]

-- Just 1000

-- (0.02 secs, 0 bytes)

-- λ> celebridad3 [(x,10^6) | x <- [1..10^6-1]]

-- Just 1000000

-- (9.56 secs, 1,572,841,088 bytes)

-- λ> celebridad3 [(x,1) | x <- [2..10^6]]

-- Just 1

-- (6.17 secs, 696,513,320 bytes)

Grafo de divisibilidad

PorJosé A. Alonso 14-mayo-201825-abril-2021

El grafo de divisibilidad de orden n es el grafo cuyos nodos son los números naturales entre 1 y n, cuyas aristas son los pares (x,y) tales que x divide a y o y divide a x. El coste de cada arista es el cociente entre su mayor y menor elemento.

Definir las siguientes funciones:

   grafoDivisibilidad :: Int -> Grafo Int Int
   coste              :: Int -> Int

1 2	grafoDivisibilidad :: Int -> Grafo Int Int coste :: Int -> Int

tales que

(grafoDivisibilidad n) es el grafo de divisibilidad de orden n. Por ejemplo,

      λ> grafoDivisibilidad 12
      G ND (array (1,12)
                  [(1,[(2,2),(3,3),(4,4),(5,5),(6,6),(7,7),
                       (8,8),(9,9),(10,10),(11,11),(12,12)]),
                   (2,[(1,2),(4,2),(6,3),(8,4),(10,5),(12,6)]),
                   (3,[(1,3),(6,2),(9,3),(12,4)]),
                   (4,[(1,4),(2,2),(8,2),(12,3)]),
                   (5,[(1,5),(10,2)]),
                   (6,[(1,6),(2,3),(3,2),(12,2)]),
                   (7,[(1,7)]),
                   (8,[(1,8),(2,4),(4,2)]),
                   (9,[(1,9),(3,3)]),
                   (10,[(1,10),(2,5),(5,2)]),
                   (11,[(1,11)]),
                   (12,[(1,12),(2,6),(3,4),(4,3),(6,2)])])

λ> grafoDivisibilidad 12

G ND (array (1,12)

[(1,[(2,2),(3,3),(4,4),(5,5),(6,6),(7,7),

(8,8),(9,9),(10,10),(11,11),(12,12)]),

(2,[(1,2),(4,2),(6,3),(8,4),(10,5),(12,6)]),

(3,[(1,3),(6,2),(9,3),(12,4)]),

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

(5,[(1,5),(10,2)]),

(6,[(1,6),(2,3),(3,2),(12,2)]),

(7,[(1,7)]),

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

(9,[(1,9),(3,3)]),

(10,[(1,10),(2,5),(5,2)]),

(11,[(1,11)]),

(12,[(1,12),(2,6),(3,4),(4,3),(6,2)])])

(coste n) es el coste del árbol de expansión mínimo del grafo de divisibilidad de orden n. Por ejemplo,

      coste 12        ==  41
      coste 3000      ==  605305
      coste (2*10^5)  ==  1711798835

coste 12 == 41

coste 3000 == 605305

coste (2*10^5) == 1711798835

Soluciones

import Data.Ix
import Data.List (delete, sort)
import qualified Data.Set as S
import I1M.Grafo
import I1M.Tabla
import Data.Numbers.Primes (primeFactors)

grafoDivisibilidad :: Int -> Grafo Int Int
grafoDivisibilidad n =
  creaGrafo ND (1,n) [(x,y,y `div` x) | y <- [1..n]
                                      , x <- [1..y-1]
                                      , y `mod` x == 0]

-- 1ª solución (con el algoritmo de Kruskal)
-- =========================================

coste1 :: Int -> Int
coste1 n = sum [p | (p,x,y) <- kruskal (grafoDivisibilidad n)]

-- (kruskal g) es el árbol de expansión mínimo del grafo g calculado
-- mediante el algoritmo de Kruskal. Por ejemplo,
--    λ> kruskal (grafoDivisibilidad 12)
--    [(11,1,11),(7,1,7),(5,1,5),(3,3,9),(3,1,3),(2,6,12),(2,5,10),
--     (2,4,8),(2,3,6),(2,2,4),(2,1,2)]
kruskal :: (Ix v, Num p, Ord p) => Grafo v p -> [(p,v,v)]
kruskal g = kruskal' cola                           -- Cola ordenada
                     (tabla [(x,x) | x <- nodos g]) -- Tabla de raices
                     []                             -- Árbol de expansión
                     (length (nodos g) - 1)         -- Aristas por
                                                    -- colocar
    where cola = sort [(p,x,y) | (x,y,p) <- aristas g]

kruskal' ((p,x,y):as) t ae n 
  | n == 0      = ae
  | actualizado = kruskal' as t' ((p,x,y):ae) (n-1)
  | otherwise   = kruskal' as t  ae           n
  where (actualizado,t') = buscaActualiza (x,y) t

-- (raiz t n) es la raíz de n en la tabla t. Por ejemplo,
--    raiz (crea [(1,1),(3,1),(4,3),(5,4),(2,6),(6,6)]) 5  == 1
--    raiz (crea [(1,1),(3,1),(4,3),(5,4),(2,6),(6,6)]) 2  == 6
raiz:: Eq n => Tabla n n -> n -> n
raiz t x | v == x    = v
         | otherwise = raiz t v
         where v = valor t x

-- (buscaActualiza a t) es el par formado por False y la tabla t, si los
-- dos vértices de la arista a tienen la misma raíz en t y el par
-- formado por True y la tabla obtenida añadiéndole a t la arista
-- formada por el vértice de a de mayor raíz y la raíz del vértice de
-- a de menor raíz. Por ejemplo,
--    ghci> let t = crea [(1,1),(2,2),(3,1),(4,1)]
--    ghci> buscaActualiza (2,3) t
--    (True,Tbl [(1,1),(2,1),(3,1),(4,1)])
--    ghci> buscaActualiza (3,4) t
--    (False,Tbl [(1,1),(2,2),(3,1),(4,1)])
buscaActualiza :: (Eq n, Ord n) => (n,n) -> Tabla n n -> (Bool,Tabla n n)
buscaActualiza (x,y) t 
  | x' == y'  = (False, t) 
  | y' <  x'  = (True, modifica (x,y') t)
  | otherwise = (True, modifica (y,x') t)
  where x' = raiz t x 
        y' = raiz t y

-- 2ª solución (con el algoritmo de Prim)
-- ======================================

coste2 :: Int -> Int
coste2 n = sum [p | (p,x,y) <- prim (grafoDivisibilidad n)]

-- (prim g) es el árbol de expansión mínimo del grafo g calculado
-- mediante el algoritmo de Prim. Por ejemplo,
--    λ> prim (grafoDivisibilidad 12)
--    [(11,1,11),(7,1,7),(2,5,10),(5,1,5),(3,3,9),(2,6,12),(2,3,6),
--     (3,1,3),(2,4,8),(2,2,4),(2,1,2)]
prim :: (Ix v, Num p, Ord p) => Grafo v p -> [(p,v,v)]
prim g = prim' [n]              -- Nodos colocados
               ns               -- Nodos por colocar 
               []               -- Árbol de expansión
               (aristas g)      -- Aristas del grafo
         where (n:ns) = nodos g

prim' t [] ae as = ae
prim' t r  ae as = prim' (v':t) (delete v' r) (e:ae) as
  where e@(c,u', v') = minimum [(c,u,v)| (u,v,c) <- as,
                                         u `elem` t, 
                                         v `elem` r]

-- 3ª solución (con el algoritmo de Prim con conjuntos)
-- ====================================================

coste3 :: Int -> Int
coste3 n = sum [p | (p,x,y) <- prim2 (grafoDivisibilidad n)]

-- (prim2 g) es el árbol de expansión mínimo del grafo g calculado
-- mediante el algoritmo de Prim. Por ejemplo,
--    λ> prim2 (grafoDivisibilidad 12)
--    [(11,1,11),(7,1,7),(2,5,10),(5,1,5),(3,3,9),(2,6,12),(2,3,6),
--     (3,1,3),(2,4,8),(2,2,4),(2,1,2)]
prim2 :: (Ix v, Num p, Ord p) => Grafo v p -> [(p,v,v)]
prim2 g = prim2' (S.singleton n)  -- Nodos colocados
                 (S.fromList ns)  -- Nodos por colocar 
                 []               -- Árbol de expansión
                 (aristas g)      -- Aristas del grafo
  where (n:ns) = nodos g

prim2' t r ae as
  | S.null r  = ae
  | otherwise = prim2' (S.insert v' t)
                       (S.delete v' r)
                       (e:ae)
                       as
  where e@(c,u', v') = minimum [(c,u,v)| (u,v,c) <- as,
                                         S.member u t, 
                                         S.member v r]

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

coste4 :: Int -> Int
coste4 n = sum [head (primeFactors x) | x <- [2..n]]

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

--    λ> coste1 400
--    14923
--    (0.08 secs, 31,336,440 bytes)
--    λ> coste2 400
--    14923
--    (4.54 secs, 220,745,608 bytes)
--    λ> coste3 400
--    14923
--    (0.69 secs, 217,031,144 bytes)
--    λ> coste4 400
--    14923
--    (0.01 secs, 2,192,336 bytes)
--    
--    λ> coste1 2000
--    284105
--    (2.09 secs, 842,601,904 bytes)
--    λ> coste4 2000
--    284105
--    (0.02 secs, 14,586,888 bytes)

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

import Data.Ix

import Data.List (delete, sort)

import qualified Data.Set as S

import I1M.Grafo

import I1M.Tabla

import Data.Numbers.Primes (primeFactors)

grafoDivisibilidad :: Int -> Grafo Int Int

grafoDivisibilidad n =

creaGrafo ND (1,n) [(x,y,y `div` x) | y <- [1..n]

, x <- [1..y-1]

, y `mod` x == 0]

-- 1ª solución (con el algoritmo de Kruskal)

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

coste1 :: Int -> Int

coste1 n = sum [p | (p,x,y) <- kruskal (grafoDivisibilidad n)]

-- (kruskal g) es el árbol de expansión mínimo del grafo g calculado

-- mediante el algoritmo de Kruskal. Por ejemplo,

-- λ> kruskal (grafoDivisibilidad 12)

-- [(11,1,11),(7,1,7),(5,1,5),(3,3,9),(3,1,3),(2,6,12),(2,5,10),

-- (2,4,8),(2,3,6),(2,2,4),(2,1,2)]

kruskal :: (Ix v, Num p, Ord p) => Grafo v p -> [(p,v,v)]

kruskal g = kruskal' cola -- Cola ordenada

(tabla [(x,x) | x <- nodos g]) -- Tabla de raices

[] -- Árbol de expansión

(length (nodos g) - 1) -- Aristas por

-- colocar

where cola = sort [(p,x,y) | (x,y,p) <- aristas g]

kruskal' ((p,x,y):as) t ae n

| n == 0 = ae

| actualizado = kruskal' as t' ((p,x,y):ae) (n-1)

| otherwise = kruskal' as t ae n

where (actualizado,t') = buscaActualiza (x,y) t

-- (raiz t n) es la raíz de n en la tabla t. Por ejemplo,

-- raiz (crea [(1,1),(3,1),(4,3),(5,4),(2,6),(6,6)]) 5 == 1

-- raiz (crea [(1,1),(3,1),(4,3),(5,4),(2,6),(6,6)]) 2 == 6

raiz:: Eq n => Tabla n n -> n -> n

raiz t x | v == x = v

| otherwise = raiz t v

where v = valor t x

-- (buscaActualiza a t) es el par formado por False y la tabla t, si los

-- dos vértices de la arista a tienen la misma raíz en t y el par

-- formado por True y la tabla obtenida añadiéndole a t la arista

-- formada por el vértice de a de mayor raíz y la raíz del vértice de

-- a de menor raíz. Por ejemplo,

-- ghci> let t = crea [(1,1),(2,2),(3,1),(4,1)]

-- ghci> buscaActualiza (2,3) t

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

-- ghci> buscaActualiza (3,4) t

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

buscaActualiza :: (Eq n, Ord n) => (n,n) -> Tabla n n -> (Bool,Tabla n n)

buscaActualiza (x,y) t

| x' == y' = (False, t)

| y' < x' = (True, modifica (x,y') t)

| otherwise = (True, modifica (y,x') t)

where x' = raiz t x

y' = raiz t y

-- 2ª solución (con el algoritmo de Prim)

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

coste2 :: Int -> Int

coste2 n = sum [p | (p,x,y) <- prim (grafoDivisibilidad n)]

-- (prim g) es el árbol de expansión mínimo del grafo g calculado

-- mediante el algoritmo de Prim. Por ejemplo,

-- λ> prim (grafoDivisibilidad 12)

-- [(11,1,11),(7,1,7),(2,5,10),(5,1,5),(3,3,9),(2,6,12),(2,3,6),

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

prim :: (Ix v, Num p, Ord p) => Grafo v p -> [(p,v,v)]

prim g = prim' [n] -- Nodos colocados

ns -- Nodos por colocar

[] -- Árbol de expansión

(aristas g) -- Aristas del grafo

where (n:ns) = nodos g

prim' t [] ae as = ae

prim' t r ae as = prim' (v':t) (delete v' r) (e:ae) as

where e@(c,u', v') = minimum [(c,u,v)| (u,v,c) <- as,

u `elem` t,

v `elem` r]

-- 3ª solución (con el algoritmo de Prim con conjuntos)

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

coste3 :: Int -> Int

coste3 n = sum [p | (p,x,y) <- prim2 (grafoDivisibilidad n)]

-- (prim2 g) es el árbol de expansión mínimo del grafo g calculado

-- mediante el algoritmo de Prim. Por ejemplo,

-- λ> prim2 (grafoDivisibilidad 12)

-- [(11,1,11),(7,1,7),(2,5,10),(5,1,5),(3,3,9),(2,6,12),(2,3,6),

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

prim2 :: (Ix v, Num p, Ord p) => Grafo v p -> [(p,v,v)]

prim2 g = prim2' (S.singleton n) -- Nodos colocados

(S.fromList ns) -- Nodos por colocar

[] -- Árbol de expansión

(aristas g) -- Aristas del grafo

where (n:ns) = nodos g

prim2' t r ae as

| S.null r = ae

| otherwise = prim2' (S.insert v' t)

(S.delete v' r)

(e:ae)

where e@(c,u', v') = minimum [(c,u,v)| (u,v,c) <- as,

S.member u t,

S.member v r]

-- 4ª solución

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

coste4 :: Int -> Int

coste4 n = sum [head (primeFactors x) | x <- [2..n]]

-- Comparación de eficiencia

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

-- λ> coste1 400

-- 14923

-- (0.08 secs, 31,336,440 bytes)

-- λ> coste2 400

-- 14923

-- (4.54 secs, 220,745,608 bytes)

-- λ> coste3 400

-- 14923

-- (0.69 secs, 217,031,144 bytes)

-- λ> coste4 400

-- 14923

-- (0.01 secs, 2,192,336 bytes)

-- λ> coste1 2000

-- 284105

-- (2.09 secs, 842,601,904 bytes)

-- λ> coste4 2000

-- 284105

-- (0.02 secs, 14,586,888 bytes)

Números construidos con los dígitos de un conjunto dado

PorJosé A. Alonso 8-mayo-201815-mayo-2018

Definir las siguientes funciones

   numerosCon      :: [Integer] -> [Integer]
   numeroDeDigitos :: [Integer] -> Integer -> Int

1 2	numerosCon :: [Integer] -> [Integer] numeroDeDigitos :: [Integer] -> Integer -> Int

tales que

(numerosCon ds) es la lista de los números que se pueden construir con los dígitos de ds (cuyos elementos son distintos elementos del 1 al 9) . Por ejemplo,

     λ> take 22 (numerosCon [1,4,6,9])
     [1,4,6,9,11,14,16,19,41,44,46,49,61,64,66,69,91,94,96,99,111,114]
     λ> take 15 (numerosCon [4,6,9])
     [4,6,9,44,46,49,64,66,69,94,96,99,444,446,449]
     λ> take 15 (numerosCon [6,9])
     [6,9,66,69,96,99,666,669,696,699,966,969,996,999,6666]

λ> take 22 (numerosCon [1,4,6,9])

[1,4,6,9,11,14,16,19,41,44,46,49,61,64,66,69,91,94,96,99,111,114]

λ> take 15 (numerosCon [4,6,9])

[4,6,9,44,46,49,64,66,69,94,96,99,444,446,449]

λ> take 15 (numerosCon [6,9])

[6,9,66,69,96,99,666,669,696,699,966,969,996,999,6666]

(numeroDeDigitos ds k) es el número de dígitos que tiene el k-ésimo elemento (empezando a contar en 0) de la sucesión (numerosCon ds). Por ejemplo,

     numeroDeDigitos [1,4,6,9]   3  ==  1
     numeroDeDigitos [1,4,6,9]   6  ==  2
     numeroDeDigitos [1,4,6,9]  22  ==  3
     numeroDeDigitos [4,6,9]    15  ==  3
     numeroDeDigitos [6,9]      15  ==  4
     numeroDeDigitos [1,4,6,9] (10^(10^5))  ==  166097
     numeroDeDigitos   [4,6,9] (10^(10^5))  ==  209590
     numeroDeDigitos     [6,9] (10^(10^5))  ==  332192

numeroDeDigitos [1,4,6,9] 3 == 1

numeroDeDigitos [1,4,6,9] 6 == 2

numeroDeDigitos [1,4,6,9] 22 == 3

numeroDeDigitos [4,6,9] 15 == 3

numeroDeDigitos [6,9] 15 == 4

numeroDeDigitos [1,4,6,9] (10^(10^5)) == 166097

numeroDeDigitos [4,6,9] (10^(10^5)) == 209590

numeroDeDigitos [6,9] (10^(10^5)) == 332192

Soluciones

import Data.List (genericIndex, genericLength)

-- Definición de numerosCon
-- ========================

numerosCon :: [Integer] -> [Integer]
numerosCon xs = [n | n <- [0..]
                   , n `tieneSusDigitosEn` xs]

-- (tieneSusDigitosEn xs n) se verifica si los dígitos de n están contenidos en
-- xs. Por ejemplo,
--    4149 `tieneSusDigitosEn` [1,4,6,9]  ==  True
--    4143 `tieneSusDigitosEn` [1,4,6,9]  ==  False
tieneSusDigitosEn :: Integer -> [Integer] -> Bool
tieneSusDigitosEn n xs =
  digitos n `esSubconjunto` xs

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

-- (esSubconjunto xs ys) se verifica si xs es subconjunto de ys. Por
-- ejemplo, 
--    esSubconjunto [3,2,5] [4,2,5,7,3]  ==  True
--    esSubconjunto [3,2,5] [4,2,5,7]  ==  False
esSubconjunto :: Eq a => [a] -> [a] -> Bool
esSubconjunto xs ys = all (`elem` ys) xs

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

numeroDeDigitos :: [Integer] -> Integer -> Int
numeroDeDigitos xs n =
  length (show (numerosCon xs `genericIndex` n))

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

-- Observando que si el conjunto de dígitos tiene n elementos, entonces
-- hay n^k números con k dígitos.

numeroDeDigitos2 :: [Integer] -> Integer -> Int
numeroDeDigitos2 xs n =
  1 + length (takeWhile (<= n) (sumasDePotencias (genericLength xs)))

-- (potencia n) son las potencias de n. Por ejemplo,
--    take 5 (potencias 3)  ==  [3,9,27,81,243]
potencias :: Integer -> [Integer]
potencias k = iterate (*k) k 

-- (sumasDePotencias n) es la lista de las sumas acumuladas de las
-- potencias de n. Por ejemplo,
--    take 5 (sumasDePotencias 3)  ==  [3,12,39,120,363]
sumasDePotencias :: Integer -> [Integer]
sumasDePotencias k = scanl1 (+) (potencias k)

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

--    λ> numeroDeDigitos [1,4,6,9] 2000
--    6
--    (3.98 secs, 1,424,390,064 bytes)
--    λ> numeroDeDigitos2 [1,4,6,9] 2000
--    6
--    (0.01 secs, 127,464 bytes)

import Data.List (genericIndex, genericLength)

-- Definición de numerosCon

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

numerosCon :: [Integer] -> [Integer]

numerosCon xs = [n | n <- [0..]

, n `tieneSusDigitosEn` xs]

-- (tieneSusDigitosEn xs n) se verifica si los dígitos de n están contenidos en

-- xs. Por ejemplo,

-- 4149 `tieneSusDigitosEn` [1,4,6,9] == True

-- 4143 `tieneSusDigitosEn` [1,4,6,9] == False

tieneSusDigitosEn :: Integer -> [Integer] -> Bool

tieneSusDigitosEn n xs =

digitos n `esSubconjunto` xs

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

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

digitos :: Integer -> [Integer]

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

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

-- ejemplo,

-- esSubconjunto [3,2,5] [4,2,5,7,3] == True

-- esSubconjunto [3,2,5] [4,2,5,7] == False

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

esSubconjunto xs ys = all (`elem` ys) xs

-- 1ª definición de numeroDeDigitos

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

numeroDeDigitos :: [Integer] -> Integer -> Int

numeroDeDigitos xs n =

length (show (numerosCon xs `genericIndex` n))

-- 2ª definición de numeroDeDigitos

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

-- Observando que si el conjunto de dígitos tiene n elementos, entonces

-- hay n^k números con k dígitos.

numeroDeDigitos2 :: [Integer] -> Integer -> Int

numeroDeDigitos2 xs n =

1 + length (takeWhile (<= n) (sumasDePotencias (genericLength xs)))

-- (potencia n) son las potencias de n. Por ejemplo,

-- take 5 (potencias 3) == [3,9,27,81,243]

potencias :: Integer -> [Integer]

potencias k = iterate (*k) k

-- (sumasDePotencias n) es la lista de las sumas acumuladas de las

-- potencias de n. Por ejemplo,

-- take 5 (sumasDePotencias 3) == [3,12,39,120,363]

sumasDePotencias :: Integer -> [Integer]

sumasDePotencias k = scanl1 (+) (potencias k)

-- Comparación de eficiencia

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

-- λ> numeroDeDigitos [1,4,6,9] 2000

-- 6

-- (3.98 secs, 1,424,390,064 bytes)

-- λ> numeroDeDigitos2 [1,4,6,9] 2000

-- 6

-- (0.01 secs, 127,464 bytes)

Números compuestos por un conjunto de primos

PorJosé A. Alonso 20-abril-201830-abril-2018

Los números compuestos por un conjunto de primos son los números cuyos factores primos pertenecen al conjunto. Por ejemplo, los primeros números compuestos por [2,5,7] son

   1,2,4,5,7,8,10,14,16,20,25,28,32,35,40,49,50,56,64,70,...

1	1,2,4,5,7,8,10,14,16,20,25,28,32,35,40,49,50,56,64,70,...

El 28 es compuesto ya que sus divisores primos son 2 y 7 que están en [2,5,7].

Definir la función

   compuestos :: [Integer] -> [Integer]

1	compuestos :: [Integer] -> [Integer]

tal que (compuesto ps) es la lista de los números compuestos por el conjunto de primos ps. Por ejemplo,

   λ> take 20 (compuestos [2,5,7])
   [1,2,4,5,7,8,10,14,16,20,25,28,32,35,40,49,50,56,64,70]
   λ> take 20 (compuestos [2,5])
   [1,2,4,5,8,10,16,20,25,32,40,50,64,80,100,125,128,160,200,250]
   λ> take 20 (compuestos [2,3,5])
   [1,2,3,4,5,6,8,9,10,12,15,16,18,20,24,25,27,30,32,36]
   λ> take 20 (compuestos [3,5,7,11,13])
   [1,3,5,7,9,11,13,15,21,25,27,33,35,39,45,49,55,63,65,75]
   λ> take 15 (compuestos [2])
   [1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384]
   λ> compuestos [2,7] !! (10^4)
   57399514149595471961908157955229677377312712667508119466382354072731648
   λ> compuestos [2,3,5] !! (10^5)
   290237644800000000000000000000000000000

λ> take 20 (compuestos [2,5,7])

[1,2,4,5,7,8,10,14,16,20,25,28,32,35,40,49,50,56,64,70]

λ> take 20 (compuestos [2,5])

[1,2,4,5,8,10,16,20,25,32,40,50,64,80,100,125,128,160,200,250]

λ> take 20 (compuestos [2,3,5])

[1,2,3,4,5,6,8,9,10,12,15,16,18,20,24,25,27,30,32,36]

λ> take 20 (compuestos [3,5,7,11,13])

[1,3,5,7,9,11,13,15,21,25,27,33,35,39,45,49,55,63,65,75]

λ> take 15 (compuestos [2])

[1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384]

λ> compuestos [2,7] !! (10^4)

57399514149595471961908157955229677377312712667508119466382354072731648

λ> compuestos [2,3,5] !! (10^5)

290237644800000000000000000000000000000

Soluciones

import Data.Numbers.Primes (primeFactors)

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

compuestos1 :: [Integer] -> [Integer]
compuestos1 ps =
  [n | n <- [1..], esCompuesto ps n]

-- (esCompuesto ps n) se verifica si los factores primos de n pertenecen
-- a ps. Por ejemplo, 
--    esCompuesto [2,3,7]    28  ==  True
--    esCompuesto [2,3,7]   140  ==  False
--    esCompuesto [2,3,5,7] 140  ==  True
esCompuesto :: [Integer] -> Integer -> Bool
esCompuesto ps n =
  subconjunto (primeFactors n) ps

-- (subconjunto xs ys) se verifica si todos los elementos de xs
-- pertenecen a ys. Por ejemplo, 
--    subconjunto [2,7,2] [7,5,2]  ==  True
--    subconjunto [2,7,3] [7,5,2]  ==  False
subconjunto :: Eq a => [a] -> [a] -> Bool
subconjunto xs ys =
  all (`elem` ys) xs

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

compuestos2 :: [Integer] -> [Integer]
compuestos2 ps =
   1 : mezclaTodas (combinaciones ps)

-- (combinaciones ps) es la lista de los productos de cada elemento de
-- ps por los números compuestos con ps. Por ejemplo,
--    λ> take 8 (compuestos4 [2,5,7])
--    [1,2,4,5,7,8,10,14]
--    λ> map (take 6) (combinaciones [2,5,7])
--    [[2,4,8,10,14,16],[5,10,20,25,35,40],[7,14,28,35,49,56]]
combinaciones :: [Integer] -> [[Integer]]
combinaciones ps =
  [[p * q | q <- compuestos2 ps] | p <- ps]

-- (mezclaTodas xss) es la mezcla ordenada de xss, donde tanto xss como
-- sus elementos son listas infinitas ordenadas. Por ejemplo, 
--    λ> take 10 (mezclaTodas [[n,2*n..] | n <- [2..]])
--    [2,3,4,5,6,7,8,9,10,11]
--    λ> take 10 (mezclaTodas [[n,2*n..] | n <- [2,9..]])
--    [2,4,6,8,9,10,12,14,16,18]
mezclaTodas :: [[Integer]] -> [Integer]
mezclaTodas = foldr1 xmezcla
  where xmezcla (x:xs) ys = x : mezcla xs ys

-- (mezcla xs ys) es la mezcla, eliminando repetidos, de las lista
-- ordenadas xs e ys. Por ejemplo,  
mezcla :: [Integer] -> [Integer] -> [Integer]
mezcla []     ys              = ys
mezcla xs     []              = xs
mezcla us@(x:xs) vs@(y:ys) | x == y     = x : mezcla xs ys
                           | x < y      = x : mezcla xs vs
                           | otherwise  = y : mezcla us ys

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

compuestos3 :: [Integer] -> [Integer]
compuestos3 [] = [1]
compuestos3 (p:ps) =
  mezclaTodas [map (*y) (compuestos3 ps) | y <- [p^k | k <- [0..]]]

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

compuestos4 :: [Integer] -> [Integer]
compuestos4 ps = foldl aux xs (tail ps)
  where p        = head ps
        xs       = [p^k | k <- [0..]]
        aux xs p = mezclaTodas [map (*y) xs | y <- [p^k | k <- [0..]]]

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

compuestos5 :: [Integer] -> [Integer]
compuestos5 = foldl aux [1] 
  where aux xs p = mezclaTodas [map (*y) xs | y <- [p^k | k <- [0..]]]

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

compuestos6 :: [Integer] -> [Integer]
compuestos6 xs = aux
  where aux = 1 : mezclas xs aux
        mezclas []     _  = []
        mezclas (x:xs) zs = mezcla (map (x*) zs) (mezclas xs zs)

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

--    λ> compuestos1 [2,3,5] !! 300
--    84375
--    (5.85 secs, 2,961,101,088 bytes)
--    λ> compuestos2 [2,3,5] !! 300
--    84375
--    (3.54 secs, 311,137,952 bytes)
--    λ> compuestos2 [2,3,5] !! 400
--    312500
--    (13.01 secs, 1,229,801,184 bytes)
--    λ> compuestos3 [2,3,5] !! 400
--    312500
--    (0.02 secs, 2,066,152 bytes)
--    λ> compuestos3 [2,3,5] !! 20000
--    15441834907098675000000
--    (1.57 secs, 203,061,864 bytes)
--    λ> compuestos4 [2,3,5] !! 20000
--    15441834907098675000000
--    (0.40 secs, 53,335,080 bytes)
--    λ> compuestos4 [2,3,5] !! 50000
--    2379528690747474604574166220800
--    (1.25 secs, 170,058,496 bytes)
--    λ> compuestos5 [2,3,5] !! 50000
--    2379528690747474604574166220800
--    (1.26 secs, 170,104,648 bytes)
--    λ> compuestos6 [2,3,5] !! 50000
--    2379528690747474604574166220800
--    (0.26 secs, 40,490,280 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

import Data.Numbers.Primes (primeFactors)

-- 1ª solución

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

compuestos1 :: [Integer] -> [Integer]

compuestos1 ps =

[n | n <- [1..], esCompuesto ps n]

-- (esCompuesto ps n) se verifica si los factores primos de n pertenecen

-- a ps. Por ejemplo,

-- esCompuesto [2,3,7] 28 == True

-- esCompuesto [2,3,7] 140 == False

-- esCompuesto [2,3,5,7] 140 == True

esCompuesto :: [Integer] -> Integer -> Bool

esCompuesto ps n =

subconjunto (primeFactors n) ps

-- (subconjunto xs ys) se verifica si todos los elementos de xs

-- pertenecen a ys. Por ejemplo,

-- subconjunto [2,7,2] [7,5,2] == True

-- subconjunto [2,7,3] [7,5,2] == False

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

subconjunto xs ys =

all (`elem` ys) xs

-- 2ª solución

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

compuestos2 :: [Integer] -> [Integer]

compuestos2 ps =

1 : mezclaTodas (combinaciones ps)

-- (combinaciones ps) es la lista de los productos de cada elemento de

-- ps por los números compuestos con ps. Por ejemplo,

-- λ> take 8 (compuestos4 [2,5,7])

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

-- λ> map (take 6) (combinaciones [2,5,7])

-- [[2,4,8,10,14,16],[5,10,20,25,35,40],[7,14,28,35,49,56]]

combinaciones :: [Integer] -> [[Integer]]

combinaciones ps =

[[p * q | q <- compuestos2 ps] | p <- ps]

-- (mezclaTodas xss) es la mezcla ordenada de xss, donde tanto xss como

-- sus elementos son listas infinitas ordenadas. Por ejemplo,

-- λ> take 10 (mezclaTodas [[n,2*n..] | n <- [2..]])

-- [2,3,4,5,6,7,8,9,10,11]

-- λ> take 10 (mezclaTodas [[n,2*n..] | n <- [2,9..]])

-- [2,4,6,8,9,10,12,14,16,18]

mezclaTodas :: [[Integer]] -> [Integer]

mezclaTodas = foldr1 xmezcla

where xmezcla (x:xs) ys = x : mezcla xs ys

-- (mezcla xs ys) es la mezcla, eliminando repetidos, de las lista

-- ordenadas xs e ys. Por ejemplo,

mezcla :: [Integer] -> [Integer] -> [Integer]

mezcla [] ys = ys

mezcla xs [] = xs

mezcla us@(x:xs) vs@(y:ys) | x == y = x : mezcla xs ys

| x < y = x : mezcla xs vs

| otherwise = y : mezcla us ys

-- 3ª solución

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

compuestos3 :: [Integer] -> [Integer]

compuestos3 [] = [1]

compuestos3 (p:ps) =

mezclaTodas [map (*y) (compuestos3 ps) | y <- [p^k | k <- [0..]]]

-- 4ª solución

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

compuestos4 :: [Integer] -> [Integer]

compuestos4 ps = foldl aux xs (tail ps)

where p = head ps

xs = [p^k | k <- [0..]]

aux xs p = mezclaTodas [map (*y) xs | y <- [p^k | k <- [0..]]]

-- 5ª solución

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

compuestos5 :: [Integer] -> [Integer]

compuestos5 = foldl aux [1]

where aux xs p = mezclaTodas [map (*y) xs | y <- [p^k | k <- [0..]]]

-- 6ª solución

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

compuestos6 :: [Integer] -> [Integer]

compuestos6 xs = aux

where aux = 1 : mezclas xs aux

mezclas [] _ = []

mezclas (x:xs) zs = mezcla (map (x*) zs) (mezclas xs zs)

-- Comparación de eficiencia

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

-- λ> compuestos1 [2,3,5] !! 300

-- 84375

-- (5.85 secs, 2,961,101,088 bytes)

-- λ> compuestos2 [2,3,5] !! 300

-- 84375

-- (3.54 secs, 311,137,952 bytes)

-- λ> compuestos2 [2,3,5] !! 400

-- 312500

-- (13.01 secs, 1,229,801,184 bytes)

-- λ> compuestos3 [2,3,5] !! 400

-- 312500

-- (0.02 secs, 2,066,152 bytes)

-- λ> compuestos3 [2,3,5] !! 20000

-- 15441834907098675000000

-- (1.57 secs, 203,061,864 bytes)

-- λ> compuestos4 [2,3,5] !! 20000

-- 15441834907098675000000

-- (0.40 secs, 53,335,080 bytes)

-- λ> compuestos4 [2,3,5] !! 50000

-- 2379528690747474604574166220800

-- (1.25 secs, 170,058,496 bytes)

-- λ> compuestos5 [2,3,5] !! 50000

-- 2379528690747474604574166220800

-- (1.26 secs, 170,104,648 bytes)

-- λ> compuestos6 [2,3,5] !! 50000

-- 2379528690747474604574166220800

-- (0.26 secs, 40,490,280 bytes)

Notas de evaluación acumulada

PorJosé A. Alonso 19-abril-201826-abril-2018

La evaluación acumulada, las notas se calculan recursivamente con la siguiente función

   N(1) = E(1)
   N(k) = máximo(E(k), 0.4*N(k-1)+0.6*E(k))

1 2	N(1) = E(1) N(k) = máximo(E(k), 0.4N(k-1)+0.6E(k))

donde E(k) es la nota del examen k. Por ejemplo, si las notas de los exámenes son [3,7,6,3] entonces las acumuladas son [3.0,7.0,6.4,4.4]

Las notas e los exámenes se encuentran en ficheros CSV con los valores separados por comas. Cada línea representa la nota de un alumno, el primer valor es el identificador del alumno y los restantes son sus notas. Por ejemplo, el contenido de examenes.csv es

   juaruigar,3,7,9,3
   evadialop,3,6,7,4
   carrodmes,0,9,8,7

juaruigar,3,7,9,3

evadialop,3,6,7,4

carrodmes,0,9,8,7

Definir las funciones

   acumuladas      :: [Double] -> [Double]
   notasAcumuladas :: FilePath -> FilePath -> IO ()

1 2	acumuladas :: [Double] -> [Double] notasAcumuladas :: FilePath -> FilePath -> IO ()

tales que

(acumuladas xs) es la lista de las notas acumuladas (redondeadas con un decimal) de los notas de los exámenes xs. Por ejemplo,

     acumuladas [2,5]      ==  [2.0,5.0]
     acumuladas [5,2]      ==  [5.0,3.2]
     acumuladas [3,7,6,3]  ==  [3.0,7.0,6.4,4.4]
     acumuladas [3,6,7,3]  ==  [3.0,6.0,7.0,4.6]

acumuladas [2,5] == [2.0,5.0]

acumuladas [5,2] == [5.0,3.2]

acumuladas [3,7,6,3] == [3.0,7.0,6.4,4.4]

acumuladas [3,6,7,3] == [3.0,6.0,7.0,4.6]

(notasAcumuladas f1 f2) que escriba en el fichero f2 las notas acumuladas correspondientes a las notas de los exámenes del fichero f1. Por ejemplo, al evaluar

     notasAcumuladas "examenes.csv" "acumuladas.csv"

1	notasAcumuladas "examenes.csv" "acumuladas.csv"

escribe en el fichero acumuladas.csv

     juaruigar,3.0,7.0,9.0,5.4
     evadialop,3.0,6.0,7.0,5.2
     carrodmes,0.0,9.0,8.4,7.6

juaruigar,3.0,7.0,9.0,5.4

evadialop,3.0,6.0,7.0,5.2

carrodmes,0.0,9.0,8.4,7.6

Soluciones

import Text.CSV
import Data.Either

-- Definicioń de acumuladas
-- ========================

acumuladas :: [Double] -> [Double]
acumuladas = reverse . aux . reverse
  where aux []     = []
        aux [x]    = [x]
        aux (x:xs) = conUnDecimal (max x (0.6*x+0.4*y)) : y : ys 
          where (y:ys) = aux xs

--    conUnDecimal 7.26  ==  7.3
--    conUnDecimal 7.24  ==  7.2
conUnDecimal :: Double -> Double
conUnDecimal x = fromIntegral (round (10*x)) / 10

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

notasAcumuladas :: FilePath -> FilePath -> IO ()
notasAcumuladas f1 f2 = do
  cs <- readFile f1
  writeFile f2 (unlines (map ( acumuladaACadena
                             . notaAAcumuladas
                             . listaANota
                             . cadenaALista
                             )
                             (contenidoALineasDeNotas cs)))

--   λ> contenidoALineasDeNotas "juaruigar,3,7,6,3\nevadialop,3,6,7,3\n\n  \n"
--   ["juaruigar,3,7,6,3","evadialop,3,6,7,3"]
contenidoALineasDeNotas :: String -> [String]
contenidoALineasDeNotas = filter esLineaDeNotas . lines
  where esLineaDeNotas = elem ','

--    cadenaALista "a,b c,d"            ==  ["a","b c","d"]
--    cadenaALista "juaruigar,3,7,6,3"  ==  ["juaruigar","3","7","6","3"]
cadenaALista :: String -> [String]
cadenaALista cs
  | tieneComas cs = d : cadenaALista ds
  | otherwise     = [cs]
  where (d,_:ds)   = span (/=',') cs
        tieneComas = elem ','

--    λ> listaANota ["juaruigar","3","7","6","3"]
--    ("juaruigar",[3.0,7.0,6.0,3.0])
listaANota :: [String] -> (String,[Double])
listaANota (x:xs) = (x,map read xs)

--   λ> notaAAcumuladas ("juaruigar",[3.0,7.0,6.0,3.0])
--   ("juaruigar",[3.0,7.0,6.4,4.4])
notaAAcumuladas :: (String,[Double]) -> (String,[Double])
notaAAcumuladas (x,xs) = (x, acumuladas xs)

--    λ> acumuladaACadena ("juaruigar",[3.0,7.0,6.4,4.4])
--    "juaruigar,3.0,7.0,6.4,4.4"
acumuladaACadena :: (String,[Double]) -> String
acumuladaACadena (x,xs) =
  x ++ "," ++ tail (init (show xs))

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

notasAcumuladas2 :: FilePath -> FilePath -> IO ()
notasAcumuladas2 f1 f2 = do
  cs <- readFile f1
  let (Right csv) = parseCSV f1 cs
  let notas = [xs | xs <- csv, length xs > 1]
  writeFile f2 (unlines (map ( acumuladaACadena
                             . notaAAcumuladas
                             . listaANota
                             )
                             notas))

import Text.CSV

import Data.Either

-- Definicioń de acumuladas

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

acumuladas :: [Double] -> [Double]

acumuladas = reverse . aux . reverse

where aux [] = []

aux [x] = [x]

aux (x:xs) = conUnDecimal (max x (0.6*x+0.4*y)) : y : ys

where (y:ys) = aux xs

-- conUnDecimal 7.26 == 7.3

-- conUnDecimal 7.24 == 7.2

conUnDecimal :: Double -> Double

conUnDecimal x = fromIntegral (round (10*x)) / 10

-- 1ª definición de notasAcumuladas

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

notasAcumuladas :: FilePath -> FilePath -> IO ()

notasAcumuladas f1 f2 = do

cs <- readFile f1

writeFile f2 (unlines (map ( acumuladaACadena

. notaAAcumuladas

. listaANota

. cadenaALista

)

(contenidoALineasDeNotas cs)))

-- λ> contenidoALineasDeNotas "juaruigar,3,7,6,3\nevadialop,3,6,7,3\n\n \n"

-- ["juaruigar,3,7,6,3","evadialop,3,6,7,3"]

contenidoALineasDeNotas :: String -> [String]

contenidoALineasDeNotas = filter esLineaDeNotas . lines

where esLineaDeNotas = elem ','

-- cadenaALista "a,b c,d" == ["a","b c","d"]

-- cadenaALista "juaruigar,3,7,6,3" == ["juaruigar","3","7","6","3"]

cadenaALista :: String -> [String]

cadenaALista cs

| tieneComas cs = d : cadenaALista ds

| otherwise = [cs]

where (d,_:ds) = span (/=',') cs

tieneComas = elem ','

-- λ> listaANota ["juaruigar","3","7","6","3"]

-- ("juaruigar",[3.0,7.0,6.0,3.0])

listaANota :: [String] -> (String,[Double])

listaANota (x:xs) = (x,map read xs)

-- λ> notaAAcumuladas ("juaruigar",[3.0,7.0,6.0,3.0])

-- ("juaruigar",[3.0,7.0,6.4,4.4])

notaAAcumuladas :: (String,[Double]) -> (String,[Double])

notaAAcumuladas (x,xs) = (x, acumuladas xs)

-- λ> acumuladaACadena ("juaruigar",[3.0,7.0,6.4,4.4])

-- "juaruigar,3.0,7.0,6.4,4.4"

acumuladaACadena :: (String,[Double]) -> String

acumuladaACadena (x,xs) =

x ++ "," ++ tail (init (show xs))

-- 2ª definición de notasAcumuladas

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

notasAcumuladas2 :: FilePath -> FilePath -> IO ()

notasAcumuladas2 f1 f2 = do

cs <- readFile f1

let (Right csv) = parseCSV f1 cs

let notas = [xs | xs <- csv, length xs > 1]

writeFile f2 (unlines (map ( acumuladaACadena

. notaAAcumuladas

. listaANota

)

notas))

La carrera de Collatz

PorJosé A. Alonso 4-abril-201811-abril-2018

Sea f la siguiente funció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.

La carrera de Collatz consiste en, dada una lista de números ns, sustituir cada número n de ns por f(n) hasta que alguno sea igual a 1. Por ejemplo, la siguiente sucesión es una carrera de Collatz

   [ 3, 6,20, 49, 73]
   [10, 3,10,148,220]
   [ 5,10, 5, 74,110]
   [16, 5,16, 37, 55]
   [ 8,16, 8,112,166]
   [ 4, 8, 4, 56, 83]
   [ 2, 4, 2, 28,250]
   [ 1, 2, 1, 14,125]

[ 3, 6,20, 49, 73]

[10, 3,10,148,220]

[ 5,10, 5, 74,110]

[16, 5,16, 37, 55]

[ 8,16, 8,112,166]

[ 4, 8, 4, 56, 83]

[ 2, 4, 2, 28,250]

[ 1, 2, 1, 14,125]

En esta carrera, los ganadores son 3 y 20.

Definir la función

   ganadores :: [Int] -> [Int]

1	ganadores :: [Int] -> [Int]

tal que (ganadores ns) es la lista de los ganadores de la carrera de Collatz a partir de la lista inicial ns. Por ejmplo,

   ganadores [3,6,20,49,73]  ==  [3,20]

1	ganadores [3,6,20,49,73] == [3,20]

Soluciones

ganadores :: [Int] -> [Int]
ganadores xs = selecciona xs (final xs)

-- (final xs) es el estado final de la carrera de Collatz a partir de
-- xs. Por ejemplo,
--    final [3,6,20,49,73]  ==  [1,2,1,14,125]
final :: [Int] -> [Int]
final xs | elem 1 xs = xs
         | otherwise = final [siguiente x | x <- xs]

-- (siguiente x) es el siguiente de x en la carrera de Collatz. Por
-- ejemplo, 
--    siguiente 3  ==  10
--    siguiente 6  ==  3
siguiente :: Int -> Int
siguiente x | even x    = x `div` 2
            | otherwise = 3*x+1

-- (selecciona xs ys) es la lista de los elementos de xs cuyos tales que
-- los elementos de ys en la misma posición son iguales a 1. Por ejemplo,
--    selecciona [3,6,20,49,73] [1,2,1,14,125]  ==  [3,20]
selecciona :: [Int] -> [Int] -> [Int]
selecciona xs ys =
  [x | (x,y) <- zip xs ys, y == 1]

ganadores :: [Int] -> [Int]

ganadores xs = selecciona xs (final xs)

-- (final xs) es el estado final de la carrera de Collatz a partir de

-- xs. Por ejemplo,

-- final [3,6,20,49,73] == [1,2,1,14,125]

final :: [Int] -> [Int]

final xs | elem 1 xs = xs

| otherwise = final [siguiente x | x <- xs]

-- (siguiente x) es el siguiente de x en la carrera de Collatz. Por

-- ejemplo,

-- siguiente 3 == 10

-- siguiente 6 == 3

siguiente :: Int -> Int

siguiente x | even x = x `div` 2

| otherwise = 3*x+1

-- (selecciona xs ys) es la lista de los elementos de xs cuyos tales que

-- los elementos de ys en la misma posición son iguales a 1. Por ejemplo,

-- selecciona [3,6,20,49,73] [1,2,1,14,125] == [3,20]

selecciona :: [Int] -> [Int] -> [Int]

selecciona xs ys =

[x | (x,y) <- zip xs ys, y == 1]

Árboles binarios completos

PorJosé A. Alonso 14-febrero-201821-febrero-2018

Un árbol binario completo es un árbol en el que cada nodo tiene cero o dos hijos. Por ejemplo, el primero de los siguientes árboles es un árbol binario completo pero los otros no lo son

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

1 1 1

/ \ / \ / | \

2 3 2 3 2 7 3

/ \ / / \

4 5 4 4 5

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 los árboles anteriores se puede representar por

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

ej1, ej2, ej3 :: Arbol Int

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

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

ej3 = N 1 [N 2 [N 4 [], N 5 []], N 7 [], N 3 []]

Definir la función

   esBinarioCompleto :: Arbol t -> Bool

1	esBinarioCompleto :: Arbol t -> Bool

tal que (esBinarioCompleto a) se verifica si a es un árbol binario completo. Por ejemplo,

   esBinarioCompleto ej1  ==  True
   esBinarioCompleto ej2  ==  False
   esBinarioCompleto ej3  ==  False

esBinarioCompleto ej1 == True

esBinarioCompleto ej2 == False

esBinarioCompleto ej3 == False

Soluciones

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

ej1, ej2, ej3 :: Arbol Int
ej1 = N 1 [N 2 [N 4 [], N 5 []], N 3 []]
ej2 = N 1 [N 2 [N 4 []], N 3 []]
ej3 = N 1 [N 2 [N 4 [], N 5 []], N 7 [], N 3 []]
          
esBinarioCompleto :: Arbol t -> Bool
esBinarioCompleto (N _ []) = True
esBinarioCompleto (N x as) = length as `elem` [0,2] 
                             && all esBinarioCompleto as

data Arbol a = N a [Arbol a]

deriving Show

ej1, ej2, ej3 :: Arbol Int

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

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

ej3 = N 1 [N 2 [N 4 [], N 5 []], N 7 [], N 3 []]

esBinarioCompleto :: Arbol t -> Bool

esBinarioCompleto (N _ []) = True

esBinarioCompleto (N x as) = length as `elem` [0,2]

&& all esBinarioCompleto as

Relaciones arbóreas

PorJosé A. Alonso 30-enero-20186-febrero-2018

Como se explica en el ejercicio Relación definida por un árbol, cada árbol binario define una relación binaria donde un elemento x está relacionado con y si x es el padre de y.

Una relación binaria es arbórea si

hay exactamente un elemento que no tiene ningún (la raíz del árbol) y
todos los elementos tienen dos hijos (los nodos internos) o ninguno (las hojas del árbol).

Definir la función

   arborea :: Eq a => [(a,a)] -> Bool

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

tal que (arborea r) se verifica si la relación r es arbórea. Por ejemplo,

   arborea [(10,8),(8,3),(8,5),(10,2),(2,2),(2,0)]  ==  True
   arborea [(8,3),(8,5),(10,2),(2,2),(2,0)]         ==  False
   arborea [(10,8),(8,3),(8,5),(10,2),(8,2),(2,0)]  ==  False

arborea [(10,8),(8,3),(8,5),(10,2),(2,2),(2,0)] == True

arborea [(8,3),(8,5),(10,2),(2,2),(2,0)] == False

arborea [(10,8),(8,3),(8,5),(10,2),(8,2),(2,0)] == False

Soluciones

import Data.List ((\\), elemIndices, isPrefixOf, nub, sort)

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

arborea :: Eq a => [(a,a)] -> Bool
arborea r =
  length [x | x <- nodos r, null (padres r x)] == 1 &&
  all (`elem` [0,2]) [length (hijos r x) | x <- nodos r]

-- (nodos r) es el conjunto de los nodos de la relación r. Por ejemplo,   
--    λ> nodos [(10,8),(8,3),(8,5),(10,2),(2,2),(2,0)]
--    [10,8,3,5,2,0]
nodos :: Eq a => [(a,a)] -> [a]
nodos r = nub (concat [[x,y] | (x,y) <- r])

-- (padres r x) es la lista de los padres de x en la relación r. Por
-- ejemplo, 
--    padres [(10,8),(8,3),(8,5),(10,2),(2,2),(2,0)] 8   ==  [10]
--    padres [(10,8),(8,3),(8,5),(10,2),(2,2),(2,0)] 10  ==  []
padres :: Eq a => [(a,a)] -> a -> [a]
padres r x = [y | (y,x') <- r, x' == x]

-- (hijos r x) es la lista de los hijos de x en la relación r. Por
-- ejemplo, 
--    hijos [(10,8),(8,3),(8,5),(10,2),(2,2),(2,0)] 10  ==  [8,2]
--    hijos [(10,8),(8,3),(8,5),(10,2),(2,2),(2,0)] 5   ==  []
hijos :: Eq a => [(a,a)] -> a -> [a]
hijos r x = [y | (x',y) <- r, x' == x]

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

arborea2 :: Eq a => [(a,a)] -> Bool
arborea2 xs =  length (nub padres \\ nub hijos) == 1
            && and [cuenta x padres == 2 | x <- nub padres]
  where
    (padres, hijos) = unzip xs

-- (cuenta x ys) es el número de ocurrencias de x en ys. Por ejemplo,
--    cuenta 7 [7,2,7,7,5]  ==  3
cuenta :: Eq a => a -> [a] -> Int
cuenta i = length . elemIndices i

import Data.List ((\\), elemIndices, isPrefixOf, nub, sort)

-- 1ª solución

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

arborea :: Eq a => [(a,a)] -> Bool

arborea r =

length [x | x <- nodos r, null (padres r x)] == 1 &&

all (`elem` [0,2]) [length (hijos r x) | x <- nodos r]

-- (nodos r) es el conjunto de los nodos de la relación r. Por ejemplo,

-- λ> nodos [(10,8),(8,3),(8,5),(10,2),(2,2),(2,0)]

-- [10,8,3,5,2,0]

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

nodos r = nub (concat [[x,y] | (x,y) <- r])

-- (padres r x) es la lista de los padres de x en la relación r. Por

-- ejemplo,

-- padres [(10,8),(8,3),(8,5),(10,2),(2,2),(2,0)] 8 == [10]

-- padres [(10,8),(8,3),(8,5),(10,2),(2,2),(2,0)] 10 == []

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

padres r x = [y | (y,x') <- r, x' == x]

-- (hijos r x) es la lista de los hijos de x en la relación r. Por

-- ejemplo,

-- hijos [(10,8),(8,3),(8,5),(10,2),(2,2),(2,0)] 10 == [8,2]

-- hijos [(10,8),(8,3),(8,5),(10,2),(2,2),(2,0)] 5 == []

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

hijos r x = [y | (x',y) <- r, x' == x]

-- 2ª solución

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

arborea2 :: Eq a => [(a,a)] -> Bool

arborea2 xs = length (nub padres \\ nub hijos) == 1

&& and [cuenta x padres == 2 | x <- nub padres]

where

(padres, hijos) = unzip xs

-- (cuenta x ys) es el número de ocurrencias de x en ys. Por ejemplo,

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

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

cuenta i = length . elemIndices i

Conjunto de funciones entre dos conjuntos

PorJosé A. Alonso 1-diciembre-20178-diciembre-2017

Una función f entre dos conjuntos A e B se puede representar mediante una lista de pares de AxB tales que para cada elemento a de A existe un único elemento b de B tal que (a,b) pertenece a f. Por ejemplo,

[(1,2),(3,6)] es una función de [1,3] en [2,4,6];
[(1,2)] no es una función de [1,3] en [2,4,6], porque no tiene ningún par cuyo primer elemento sea igual a 3;
[(1,2),(3,6),(1,4)] no es una función porque hay dos pares distintos cuya primera coordenada es 1.

Definir las funciones

   funciones  :: (Ord a, Ord b) => [a] -> [b] -> [[(a,b)]]
   nFunciones :: (Ord a, Ord b) => [a] -> [b] -> Integer

1 2	funciones :: (Ord a, Ord b) => [a] -> [b] -> [[(a,b)]] nFunciones :: (Ord a, Ord b) => [a] -> [b] -> Integer

tales que

(funciones xs ys) es el conjunto de las funciones del conjunto xs en el conjunto ys. Por ejemplo,

     λ> funciones [1] [2]
     [[(1,2)]]
     λ> funciones [1] [2,4]
     [[(1,2)],[(1,4)]]
     λ> funciones [1,3] [2]
     [[(1,2),(3,2)]]
     λ> funciones [1,3] [2,4]
     [[(1,2),(3,2)],[(1,2),(3,4)],[(1,4),(3,2)],[(1,4),(3,4)]]
     λ> funciones [1,3] [2,4,6]
     [[(1,2),(3,2)],[(1,2),(3,4)],[(1,2),(3,6)],
      [(1,4),(3,2)],[(1,4),(3,4)],[(1,4),(3,6)],
      [(1,6),(3,2)],[(1,6),(3,4)],[(1,6),(3,6)]]
     λ> funciones [1,3,5] [2,4]
     [[(1,2),(3,2),(5,2)],[(1,2),(3,2),(5,4)],[(1,2),(3,4),(5,2)],
      [(1,2),(3,4),(5,4)],[(1,4),(3,2),(5,2)],[(1,4),(3,2),(5,4)],
      [(1,4),(3,4),(5,2)],[(1,4),(3,4),(5,4)]]
     λ> funciones [] []
     [[]]
     λ> funciones [] [2]
     [[]]
     λ> funciones [1] []
     []

λ> funciones [1] [2]

[[(1,2)]]

λ> funciones [1] [2,4]

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

λ> funciones [1,3] [2]

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

λ> funciones [1,3] [2,4]

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

λ> funciones [1,3] [2,4,6]

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

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

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

λ> funciones [1,3,5] [2,4]

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

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

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

λ> funciones [] []

[[]]

λ> funciones [] [2]

[[]]

λ> funciones [1] []

[]

(nFunciones xs ys) es el número de funciones del conjunto xs en el conjunto ys. Por ejemplo,

     nFunciones [1,3] [2,4,6]  ==  9
     nFunciones [1,3,5] [2,4]  ==  8
     length (show (nFunciones2 [1..10^6] [1..10^3]))  ==  3000001

nFunciones [1,3] [2,4,6] == 9

nFunciones [1,3,5] [2,4] == 8

length (show (nFunciones2 [1..10^6] [1..10^3])) == 3000001

Soluciones

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

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

funciones :: (Ord a, Ord b) => [a] -> [b] -> [[(a,b)]]
funciones xs ys =
  conjunto [r | r <- relaciones xs ys
              , esFuncion r xs ys]

-- (relaciones xs ys) es el conjunto de las relaciones binarias entre xs
-- e ys. Por ejemplo,
--    λ> relaciones [1,3] [2,4]
--    [[],[(1,2)],[(1,4)],[(1,2),(1,4)],[(3,2)],[(1,2),(3,2)],
--     [(1,4),(3,2)],[(1,2),(1,4),(3,2)],[(3,4)],[(1,2),(3,4)],
--     [(1,4),(3,4)],[(1,2),(1,4),(3,4)],[(3,2),(3,4)],
--     [(1,2),(3,2),(3,4)],[(1,4),(3,2),(3,4)],
--     [(1,2),(1,4),(3,2),(3,4)]]
relaciones :: [a] -> [b] -> [[(a,b)]]
relaciones xs ys =
  subsequences (producto xs ys)

-- (producto xs ys) es el producto cartesiano de xs e ys. Por ejemplo,
--    producto [1,3] [2,4]  ==  [(1,2),(1,4),(3,2),(3,4)]
producto :: [a] -> [b] -> [(a,b)]
producto xs ys =
  [(x,y) | x <- xs, y <- ys]

-- (esFuncional r) r se verifica si la relación r es funcional. Por
-- ejemplo, 
--    esFuncional [(2,4),(1,5),(3,4)]        ==  True
--    esFuncional [(3,4),(1,4),(1,2),(3,4)]  ==  False
esFuncional :: (Ord a, Ord b) => [(a,b)] -> Bool
esFuncional r =
  and [esUnitario (imagen r x) | x <- dominio r] 

-- (dominio r) es el dominio de la relación r. Por ejemplo,
--    dominio [(5,4),(1,4),(1,2),(3,4)]  ==  [1,3,5]
dominio :: Ord a => [(a,b)] -> [a]
dominio = sort . nub . map fst

-- (imagen r x) es la imagen de x en la relación r. Por ejemplo,
--    imagen [(5,4),(1,4),(1,2),(3,4)] 1  ==  [2,4]
--    imagen [(5,4),(1,4),(1,2),(3,4)] 2  ==  []
imagen :: (Ord a, Ord b) => [(a,b)] -> a -> [b]
imagen r x =
  conjunto [y | (x1,y) <- r, x1 == x]

-- (conjunto xs) es el conjunto (es decir, lista ordenada de elementos
-- distintos) correspondiente a la lista xs. Por ejemplo, 
--    conjunto [7,2,3,2,7,3]  ==  [2,3,7]
conjunto :: Ord a => [a] -> [a]
conjunto = sort . nub

-- (esUnitario xs) se verifica si xs tiene sólo un elemento.
esUnitario :: [a] -> Bool
esUnitario xs =
  length xs == 1

-- (esFuncion r xs ys) se verifica si r es una función con dominio xs y
-- codominio ys. Por ejemplo,
--    esFuncion [(2,4),(1,5),(3,4)] [1,2,3] [4,5,7]   ==  True
--    esFuncion [(2,4),(1,5),(3,4)] [1,3] [4,5,7]     ==  False
--    esFuncion [(2,4),(1,5),(3,4)] [1,2,3] [4,7]     ==  False
--    esFuncion [(1,4),(1,5),(3,4)] [1,2,3] [4,5,7]   ==  False
esFuncion :: (Ord a, Ord b) => [(a,b)] -> [a] -> [b] -> Bool
esFuncion r xs ys =
     conjunto xs == dominio r 
  && rango r `contenido` conjunto ys
  && esFuncional r

-- (rango r) es el rango de la relación r. Por ejemplo,
--    rango [(5,4),(1,4),(1,2),(3,4)]  ==  [2,4]
rango :: Ord b => [(a,b)] -> [b]
rango = sort . nub . map snd

-- (contenido xs ys) se verifica si el conjunto xs está contenido en el
-- ys. Por ejemplo,
--    [1,3] `contenido` [1,2,3,5]  ==  True
--    [1,3] `contenido` [1,2,4,5]  ==  False
contenido :: Ord a => [a] -> [a] -> Bool 
contenido xs ys =
  all (`elem` ys) xs

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

funciones2 :: (Ord a, Ord b) => [a] -> [b] -> [[(a,b)]]
funciones2 xs ys =
  conjunto (aux xs ys)
  where aux [] _      = [[]]
        aux [x] ys    = [[(x,y)] | y <- ys]
        aux (x:xs) ys = [((x,y):f) | y <- ys, f <- fs]
          where fs = aux xs ys

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

--    λ> length (funciones [1..4] [1..4]) 
--    256
--    (2.69 secs, 754,663,072 bytes)
--    λ> length (funciones2 [1..4] [1..4]) 
--    256
--    (0.04 secs, 243,600 bytes)

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

nFunciones :: (Ord a, Ord b) => [a] -> [b] -> Integer
nFunciones xs ys =
  genericLength (funciones2 xs ys)

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

nFunciones2 :: (Ord a, Ord b) => [a] -> [b] -> Integer
nFunciones2 xs ys =
  (genericLength ys)^(genericLength xs)

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

--    λ> nFunciones [1..5] [1..5] 
--    3125
--    (1.35 secs, 1,602,872 bytes)
--    λ> nFunciones2 [1..5] [1..5] 
--    3125
--    (0.03 secs, 140,480 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

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

-- 1ª definición de funciones

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

funciones :: (Ord a, Ord b) => [a] -> [b] -> [[(a,b)]]

funciones xs ys =

conjunto [r | r <- relaciones xs ys

, esFuncion r xs ys]

-- (relaciones xs ys) es el conjunto de las relaciones binarias entre xs

-- e ys. Por ejemplo,

-- λ> relaciones [1,3] [2,4]

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

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

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

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

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

relaciones :: [a] -> [b] -> [[(a,b)]]

relaciones xs ys =

subsequences (producto xs ys)

-- (producto xs ys) es el producto cartesiano de xs e ys. Por ejemplo,

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

producto :: [a] -> [b] -> [(a,b)]

producto xs ys =

[(x,y) | x <- xs, y <- ys]

-- (esFuncional r) r se verifica si la relación r es funcional. Por

-- ejemplo,

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

-- esFuncional [(3,4),(1,4),(1,2),(3,4)] == False

esFuncional :: (Ord a, Ord b) => [(a,b)] -> Bool

esFuncional r =

and [esUnitario (imagen r x) | x <- dominio r]

-- (dominio r) es el dominio de la relación r. Por ejemplo,

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

dominio :: Ord a => [(a,b)] -> [a]

dominio = sort . nub . map fst

-- (imagen r x) es la imagen de x en la relación r. Por ejemplo,

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

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

imagen :: (Ord a, Ord b) => [(a,b)] -> a -> [b]

imagen r x =

conjunto [y | (x1,y) <- r, x1 == x]

-- (conjunto xs) es el conjunto (es decir, lista ordenada de elementos

-- distintos) correspondiente a la lista xs. Por ejemplo,

-- conjunto [7,2,3,2,7,3] == [2,3,7]

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

conjunto = sort . nub

-- (esUnitario xs) se verifica si xs tiene sólo un elemento.

esUnitario :: [a] -> Bool

esUnitario xs =

length xs == 1

-- (esFuncion r xs ys) se verifica si r es una función con dominio xs y

-- codominio ys. Por ejemplo,

-- esFuncion [(2,4),(1,5),(3,4)] [1,2,3] [4,5,7] == True

-- esFuncion [(2,4),(1,5),(3,4)] [1,3] [4,5,7] == False

-- esFuncion [(2,4),(1,5),(3,4)] [1,2,3] [4,7] == False

-- esFuncion [(1,4),(1,5),(3,4)] [1,2,3] [4,5,7] == False

esFuncion :: (Ord a, Ord b) => [(a,b)] -> [a] -> [b] -> Bool

esFuncion r xs ys =

conjunto xs == dominio r

&& rango r `contenido` conjunto ys

&& esFuncional r

-- (rango r) es el rango de la relación r. Por ejemplo,

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

rango :: Ord b => [(a,b)] -> [b]

rango = sort . nub . map snd

-- (contenido xs ys) se verifica si el conjunto xs está contenido en el

-- ys. Por ejemplo,

-- [1,3] `contenido` [1,2,3,5] == True

-- [1,3] `contenido` [1,2,4,5] == False

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

contenido xs ys =

all (`elem` ys) xs

-- 2ª definición de funciones

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

funciones2 :: (Ord a, Ord b) => [a] -> [b] -> [[(a,b)]]

funciones2 xs ys =

conjunto (aux xs ys)

where aux [] _ = [[]]

aux [x] ys = [[(x,y)] | y <- ys]

aux (x:xs) ys = [((x,y):f) | y <- ys, f <- fs]

where fs = aux xs ys

-- Comparación de eficiencia de funciones

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

-- λ> length (funciones [1..4] [1..4])

-- 256

-- (2.69 secs, 754,663,072 bytes)

-- λ> length (funciones2 [1..4] [1..4])

-- 256

-- (0.04 secs, 243,600 bytes)

-- 1ª definición de nFunciones

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

nFunciones :: (Ord a, Ord b) => [a] -> [b] -> Integer

nFunciones xs ys =

genericLength (funciones2 xs ys)

-- 2ª definición de nFunciones

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

nFunciones2 :: (Ord a, Ord b) => [a] -> [b] -> Integer

nFunciones2 xs ys =

(genericLength ys)^(genericLength xs)

-- Comparación de eficiencia de nFunciones

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

-- λ> nFunciones [1..5] [1..5]

-- 3125

-- (1.35 secs, 1,602,872 bytes)

-- λ> nFunciones2 [1..5] [1..5]

-- 3125

-- (0.03 secs, 140,480 bytes)

Menor x tal que los x múltiplos de n contienen todos los dígitos

PorJosé A. Alonso 28-noviembre-20178-diciembre-2017

Definir la función

   menorX :: Integer -> Integer

1	menorX :: Integer -> Integer

tal que (menorX n) es el menor x tal que entre los x primeros múltiplos de n (es decir, entre n, 2×n, 3×n, … y x×n) contienen todos los dígitos al menos una vez. Por ejemplo, (menorX 92) es 6 ya que

   92                                    contiene  [2,9]
   92 y 92×2                             contienen [1,2,4,8,9]
   92,  92×2 y 92×3                      contienen [1,2,4,6,7,8,9]
   92,  92×2,  92×3 y 92×4               contienen [1,2,3,4,6,7,8,9]
   92,  92×2,  92×3,  92×4 y 92×5        contienen [0,1,2,3,4,6,7,8,9]
   92,  92×2,  92×3,  92×4,  92×5 y 92×6 contienen [0,1,2,3,4,5,6,7,8,9]

92 contiene [2,9]

92 y 92×2 contienen [1,2,4,8,9]

92, 92×2 y 92×3 contienen [1,2,4,6,7,8,9]

92, 92×2, 92×3 y 92×4 contienen [1,2,3,4,6,7,8,9]

92, 92×2, 92×3, 92×4 y 92×5 contienen [0,1,2,3,4,6,7,8,9]

92, 92×2, 92×3, 92×4, 92×5 y 92×6 contienen [0,1,2,3,4,5,6,7,8,9]

Otros ejemplos

   menorX 92          ==  6
   menorX 2967        ==  3
   menorX 266         ==  4
   menorX 18          ==  5
   menorX 2           ==  45
   menorX 125         ==  72
   menorX 1234567890  ==  1
   maximum [menorX n | n <- [1..3000]]  ==  72
   minimum [menorX n | n <- [1..3000]]  ==  3

menorX 92 == 6

menorX 2967 == 3

menorX 266 == 4

menorX 18 == 5

menorX 2 == 45

menorX 125 == 72

menorX 1234567890 == 1

maximum [menorX n | n <- [1..3000]] == 72

minimum [menorX n | n <- [1..3000]] == 3

Soluciones

import Data.List ((\\))

-- 1ª definición
-- =============

menorX :: Integer -> Integer
menorX n =
  head [x | x <- [1..]
          , [0..9] `contenido` digitosMultiplos n x]

contenido :: Eq a => [a] -> [a] -> Bool
contenido xs ys =
  all (`elem` ys) xs

digitosMultiplos :: Integer -> Integer -> [Integer]
digitosMultiplos n x =
  concatMap digitos [n,2*n..x*n]

digitos :: Integer -> [Integer]
digitos n =
  [read [c] | c <- show n]

-- 2ª definición
-- =============

menorX2 :: Integer -> Integer
menorX2 n = aux [] 0
  where aux xs x
          | [0..9] `contenido` xs = x
          | otherwise             = aux (digitos (n*(x+1)) ++ xs) (x+1)

-- 3ª definición
-- =============

menorX3 :: Integer -> Integer
menorX3 n = aux ['0'..'9'] 0
  where aux xs x
          | null xs   = x
          | otherwise = aux (xs \\ show (n*(x+1))) (x+1)

-- 4ª definición
-- =============

menorX4 :: Integer -> Integer
menorX4 n = aux "0123456789" 1 n
  where aux xs x nx | null ys   = x
                    | otherwise = aux ys (1+x) (nx+n)
          where ys = xs \\ show nx

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

--    λ> maximum [menorX n | n <- [1..6000]]
--    72
--    (2.04 secs, 3,737,579,888 bytes)
--    λ> maximum [menorX2 n | n <- [1..6000]]
--    72
--    (0.52 secs, 818,602,736 bytes)
--    λ> maximum [menorX3 n | n <- [1..6000]]
--    72
--    (0.10 secs, 67,090,800 bytes)
--    λ> maximum [menorX3 n | n <- [1..6000]]
--    72
--    (0.08 secs, 67,090,800 bytes)
--    
--    λ> maximum [menorX3 n | n <- [1..10^5]]
--    72
--    (0.81 secs, 1,044,781,216 bytes)
--    λ> maximum [menorX4 n | n <- [1..10^5]]
--    72
--    (0.71 secs, 1,009,113,304 bytes)

import Data.List ((\\))

-- 1ª definición

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

menorX :: Integer -> Integer

menorX n =

head [x | x <- [1..]

, [0..9] `contenido` digitosMultiplos n x]

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

contenido xs ys =

all (`elem` ys) xs

digitosMultiplos :: Integer -> Integer -> [Integer]

digitosMultiplos n x =

concatMap digitos [n,2*n..x*n]

digitos :: Integer -> [Integer]

digitos n =

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

-- 2ª definición

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

menorX2 :: Integer -> Integer

menorX2 n = aux [] 0

where aux xs x

| [0..9] `contenido` xs = x

| otherwise = aux (digitos (n*(x+1)) ++ xs) (x+1)

-- 3ª definición

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

menorX3 :: Integer -> Integer

menorX3 n = aux ['0'..'9'] 0

where aux xs x

| null xs = x

| otherwise = aux (xs \\ show (n*(x+1))) (x+1)

-- 4ª definición

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

menorX4 :: Integer -> Integer

menorX4 n = aux "0123456789" 1 n

where aux xs x nx | null ys = x

| otherwise = aux ys (1+x) (nx+n)

where ys = xs \\ show nx

-- Comparación de eficiencia

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

-- λ> maximum [menorX n | n <- [1..6000]]

-- 72

-- (2.04 secs, 3,737,579,888 bytes)

-- λ> maximum [menorX2 n | n <- [1..6000]]

-- 72

-- (0.52 secs, 818,602,736 bytes)

-- λ> maximum [menorX3 n | n <- [1..6000]]

-- 72

-- (0.10 secs, 67,090,800 bytes)

-- λ> maximum [menorX3 n | n <- [1..6000]]

-- 72

-- (0.08 secs, 67,090,800 bytes)

-- λ> maximum [menorX3 n | n <- [1..10^5]]

-- 72

-- (0.81 secs, 1,044,781,216 bytes)

-- λ> maximum [menorX4 n | n <- [1..10^5]]

-- 72

-- (0.71 secs, 1,009,113,304 bytes)

Cadenas de sumas de factoriales de los dígitos

PorJosé A. Alonso 17-noviembre-201725-noviembre-2017

Dado un número n se considera la sucesión cuyo primer término es n y los restantes se obtienen sumando los factoriales de los dígitos del anterior. Por ejemplo, la sucesión que empieza en 69 es

         69
     363600  (porque 6! + 9! = 363600)  
       1454  (porque 3! + 6! + 3! + 6! + 0! + 0! = 1454)
        169  (porque 1! + 4! + 5! + 4! = 169)
     363601  (porque 1! + 6! + 9! = 363601)
       1454  (porque 3! + 6! + 3! + 6! + 0! + 1! = 1454)
     ......

363600 (porque 6! + 9! = 363600)

1454 (porque 3! + 6! + 3! + 6! + 0! + 0! = 1454)

169 (porque 1! + 4! + 5! + 4! = 169)

363601 (porque 1! + 6! + 9! = 363601)

1454 (porque 3! + 6! + 3! + 6! + 0! + 1! = 1454)

......

La cadena correspondiente a un número n son los términos de la sucesión que empieza en n hasta la primera repetición de un elemento en la sucesión. Por ejemplo, la cadena de 69 es

   [69,363600,1454,169,363601,1454]

1	[69,363600,1454,169,363601,1454]

Consta de una parte no periódica ([69,363600]) y de una periódica ([1454,169,363601]).

Definir las funciones

   cadena  :: Integer -> [Integer]
   periodo :: Integer -> [Integer]

1 2	cadena :: Integer -> [Integer] periodo :: Integer -> [Integer]

tales que

(cadena n es la cadena correspondiente al número n. Por ejemplo,

      cadena 69    ==  [69,363600,1454,169,363601,1454]
      cadena 145   ==  [145,145]
      cadena 78    ==  [78,45360,871,45361,871]
      cadena 569   ==  [569,363720,5775,10320,11,2,2]
      cadena 3888  ==  [3888,120966,364324,782,45362,872,45362]
      maximum [length (cadena n) | n <- [1..5000]]  ==  61
      length (cadena 1479)                          ==  61

cadena 69 == [69,363600,1454,169,363601,1454]

cadena 145 == [145,145]

cadena 78 == [78,45360,871,45361,871]

cadena 569 == [569,363720,5775,10320,11,2,2]

cadena 3888 == [3888,120966,364324,782,45362,872,45362]

maximum [length (cadena n) | n <- [1..5000]] == 61

length (cadena 1479) == 61

(periodo n) es la parte periódica de la cadena de n. Por ejemplo,

      periodo 69    ==  [169,363601,1454]
      periodo 145   ==  [145]
      periodo 78    ==  [45361,871]
      periodo 569   ==  [2]
      periodo 3888  ==  [872,45362]
      maximum [length (periodo n) | n <- [1..5000]]  ==  3
      length (periodo 1479)                          ==  3

periodo 69 == [169,363601,1454]

periodo 145 == [145]

periodo 78 == [45361,871]

periodo 569 == [2]

periodo 3888 == [872,45362]

maximum [length (periodo n) | n <- [1..5000]] == 3

length (periodo 1479) == 3

Soluciones

-- Definición de cadena
-- ====================

cadena :: Integer -> [Integer]
cadena n = reverse (extension [n])

extension :: [Integer] -> [Integer]
extension (n:ns)
  | m `elem` (n:ns) = m : n : ns
  | otherwise       = extension (m : n : ns)
  where m = siguiente n

siguiente :: Integer -> Integer
siguiente n =
  sum [factorial d | d <- digitos n]

factorial :: Integer -> Integer
factorial n =
  product [1..n]

digitos :: Integer -> [Integer]
digitos n =
  [read [c] | c <- show n]

-- Definición de periodo
-- =====================

periodo :: Integer -> [Integer]
periodo n =
  reverse (x : takeWhile (/= x) xs)
  where (x:xs) = reverse (cadena n)

-- Definición de cadena

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

cadena :: Integer -> [Integer]

cadena n = reverse (extension [n])

extension :: [Integer] -> [Integer]

extension (n:ns)

| m `elem` (n:ns) = m : n : ns

| otherwise = extension (m : n : ns)

where m = siguiente n

siguiente :: Integer -> Integer

siguiente n =

sum [factorial d | d <- digitos n]

factorial :: Integer -> Integer

factorial n =

product [1..n]

digitos :: Integer -> [Integer]

digitos n =

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

-- Definición de periodo

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

periodo :: Integer -> [Integer]

periodo n =

reverse (x : takeWhile (/= x) xs)

where (x:xs) = reverse (cadena n)

El problema de las celebridades

PorJosé A. Alonso 9-mayo-201725-abril-2021

La relación de conocimiento se puede representar mediante una lista de pares (x,y) indicando que x conoce a y. Por ejemplo, ka reunioń anterior se puede representar por [(1,3),(2,1),(2,3)].

Definir la función

   celebridad :: Ord a => [(a,a)] -> Maybe a

1	celebridad :: Ord a => [(a,a)] -> Maybe a

tal que (celebridad r) es el justo la celebridad de r, si en r hay una celebridad y Nothing, en caso contrario. Por ejemplo,

   celebridad [(1,3),(2,1),(2,3)]            ==  Just 3
   celebridad [(1,3),(2,1),(3,2)]            ==  Nothing
   celebridad [(1,3),(2,1),(2,3),(3,1)]      ==  Nothing
   celebridad [(x,1) | x <- [2..10^6]]       ==  Just 1
   celebridad [(x,10^6) | x <- [1..10^6-1]]  ==  Just 1000000

celebridad [(1,3),(2,1),(2,3)] == Just 3

celebridad [(1,3),(2,1),(3,2)] == Nothing

celebridad [(1,3),(2,1),(2,3),(3,1)] == Nothing

celebridad [(x,1) | x <- [2..10^6]] == Just 1

celebridad [(x,10^6) | x <- [1..10^6-1]] == Just 1000000

Soluciones

[schedule expon=’2017-05-16′ expat=»06:00″]

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

[/schedule]

[schedule on=’2017-05-16′ at=»06:00″]

import Data.List (delete, nub)
import Data.Maybe (listToMaybe)
import qualified Data.Set as S

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

celebridad1 :: Ord a => [(a,a)] -> Maybe a
celebridad1 r =
  listToMaybe [x | x <- personas r, esCelebridad r x]

personas :: Ord a => [(a,a)] -> [a]
personas r =
  nub (map fst r ++ map snd r)

esCelebridad :: Ord a => [(a,a)] -> a -> Bool
esCelebridad r x =
     [y | y <- ys, (y,x) `elem` r] == ys
  && null [y | y <- ys, (x,y) `elem` r]
  where ys = delete x (personas r)

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

celebridad2 :: Ord a => [(a,a)] -> Maybe a
celebridad2 r =
  listToMaybe [x | x <- personas2 c, esCelebridad2 c x]
  where c = S.fromList r

--    λ> personas2 (S.fromList [(1,3),(2,1),(2,3)])
--    [1,2,3]
personas2 :: Ord a => S.Set (a,a) -> [a]
personas2 c =
  S.toList (S.map fst c `S.union` S.map snd c)

esCelebridad2 :: Ord a => S.Set (a,a) -> a -> Bool
esCelebridad2 c x = 
      [y | y <- ys, (y,x) `S.member` c] == ys
   && null [y | y <- ys, (x,y) `S.member` c]
   where ys = delete x (personas2 c)

-- 3ª definición
-- =============

celebridad3 :: Ord a => [(a,a)] -> Maybe a
celebridad3 r
  | S.null candidatos = Nothing
  | esCelebridad      = Just candidato
  | otherwise         = Nothing
  where
    conjunto          = S.fromList r
    dominio           = S.map fst conjunto
    rango             = S.map snd conjunto
    total             = dominio `S.union` rango
    candidatos        = rango `S.difference` dominio
    candidato         = S.findMin candidatos
    noCandidatos      = S.delete candidato total
    esCelebridad      =
      S.filter (\x -> (x,candidato) `S.member` conjunto) total == noCandidatos
     
-- Comparación de eficiencia
-- =========================

--    λ> celebridad1 [(x,1) | x <- [2..300]]
--    Just 1
--    (2.70 secs, 38,763,888 bytes)
--    λ> celebridad2 [(x,1) | x <- [2..300]]
--    Just 1
--    (0.01 secs, 0 bytes)
-- 
--    λ> celebridad2 [(x,1000) | x <- [1..999]]
--    Just 1000
--    (2.23 secs, 483,704,224 bytes)
--    λ> celebridad3 [(x,1000) | x <- [1..999]]
--    Just 1000
--    (0.02 secs, 0 bytes)
-- 
--    λ> celebridad3 [(x,10^6) | x <- [1..10^6-1]]
--    Just 1000000
--    (9.56 secs, 1,572,841,088 bytes)
--    λ> celebridad3 [(x,1) | x <- [2..10^6]]
--    Just 1
--    (6.17 secs, 696,513,320 bytes)

import Data.List (delete, nub)

import Data.Maybe (listToMaybe)

import qualified Data.Set as S

-- 1ª solución

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

celebridad1 :: Ord a => [(a,a)] -> Maybe a

celebridad1 r =

listToMaybe [x | x <- personas r, esCelebridad r x]

personas :: Ord a => [(a,a)] -> [a]

personas r =

nub (map fst r ++ map snd r)

esCelebridad :: Ord a => [(a,a)] -> a -> Bool

esCelebridad r x =

[y | y <- ys, (y,x) `elem` r] == ys

&& null [y | y <- ys, (x,y) `elem` r]

where ys = delete x (personas r)

-- 2ª solución

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

celebridad2 :: Ord a => [(a,a)] -> Maybe a

celebridad2 r =

listToMaybe [x | x <- personas2 c, esCelebridad2 c x]

where c = S.fromList r

-- λ> personas2 (S.fromList [(1,3),(2,1),(2,3)])

-- [1,2,3]

personas2 :: Ord a => S.Set (a,a) -> [a]

personas2 c =

S.toList (S.map fst c `S.union` S.map snd c)

esCelebridad2 :: Ord a => S.Set (a,a) -> a -> Bool

esCelebridad2 c x =

[y | y <- ys, (y,x) `S.member` c] == ys

&& null [y | y <- ys, (x,y) `S.member` c]

where ys = delete x (personas2 c)

-- 3ª definición

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

celebridad3 :: Ord a => [(a,a)] -> Maybe a

celebridad3 r

| S.null candidatos = Nothing

| esCelebridad = Just candidato

| otherwise = Nothing

where

conjunto = S.fromList r

dominio = S.map fst conjunto

rango = S.map snd conjunto

total = dominio `S.union` rango

candidatos = rango `S.difference` dominio

candidato = S.findMin candidatos

noCandidatos = S.delete candidato total

esCelebridad =

S.filter (\x -> (x,candidato) `S.member` conjunto) total == noCandidatos

-- Comparación de eficiencia

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

-- λ> celebridad1 [(x,1) | x <- [2..300]]

-- Just 1

-- (2.70 secs, 38,763,888 bytes)

-- λ> celebridad2 [(x,1) | x <- [2..300]]

-- Just 1

-- (0.01 secs, 0 bytes)

-- λ> celebridad2 [(x,1000) | x <- [1..999]]

-- Just 1000

-- (2.23 secs, 483,704,224 bytes)

-- λ> celebridad3 [(x,1000) | x <- [1..999]]

-- Just 1000

-- (0.02 secs, 0 bytes)

-- λ> celebridad3 [(x,10^6) | x <- [1..10^6-1]]

-- Just 1000000

-- (9.56 secs, 1,572,841,088 bytes)

-- λ> celebridad3 [(x,1) | x <- [2..10^6]]

-- Just 1

-- (6.17 secs, 696,513,320 bytes)

[/schedule]

Subnúmeros pares

PorJosé A. Alonso 18-abril-201725-abril-2017

Los subnúmeros de un número x son los números que se pueden formar con dígitos de x en posiciones consecutivas. Por ejemplo, el número 254 tiene 6 subnúmeros: 2, 5, 4, 25, 54 y 254.

Definir las funciones

   subnumeros       :: Integer -> [Integer]
   nSubnumerosPares :: Integer -> Integer

1 2	subnumeros :: Integer -> [Integer] nSubnumerosPares :: Integer -> Integer

tales que

(subnumerosPares x) es la lista de los subnúmeros pares de x. Por ejemplo,

     subnumerosPares 254   ==  [2,254,54,4]
     subnumerosPares 154   ==  [154,54,4]
     subnumerosPares 15    ==  []

subnumerosPares 254 == [2,254,54,4]

subnumerosPares 154 == [154,54,4]

subnumerosPares 15 == []

(nSubnumerosPares x) es la cantidad de subnúmeros pares de x. Por ejemplo,

     nSubnumerosPares 254   ==  4
     nSubnumerosPares2 (4^(10^6))  ==  90625258498

1 2	nSubnumerosPares 254 == 4 nSubnumerosPares2 (4^(10^6)) == 90625258498

Soluciones

import Data.List ( genericLength
                 , inits
                 , tails
                 )

subnumerosPares :: Integer -> [Integer]
subnumerosPares n =
  filter even (subnumeros n)

-- (subnumeros n) es la lista de los subnúmeros de n. Por ejemplo,
--    subnumeros 254  ==  [2,25,5,254,54,4]
subnumeros :: Integer -> [Integer]
subnumeros n =
  [read x | x <- sublistas (show n)]

-- (sublistas xs) es la lista de las sublistas de xs. Por ejemplo, 
--    sublistas "abc"  ==  ["a","ab","b","abc","bc","c"]
sublistas :: [a] -> [[a]]
sublistas xs =
  concat [init (tails ys) | ys <- tail (inits xs)]

-- 1ª definición
-- =============

nSubnumerosPares :: Integer -> Integer
nSubnumerosPares =
  genericLength . subnumerosPares

-- 2ª definición
-- =============

nSubnumerosPares2 :: Integer -> Integer
nSubnumerosPares2 =
  sum . posicionesDigitosPares 

-- (posicionesDigitosPares x) es la lista de las posiciones de los
-- dígitos pares de x. Por ejemplo,
--    posicionesDigitosPares 254  ==  [1,3]
posicionesDigitosPares :: Integer -> [Integer]
posicionesDigitosPares x =
  [n | (n,y) <- zip [1..] (show x)
     , y `elem` "02468"]

-- Comparación de eficiencia
--    λ> nSubnumerosPares (2^(10^3))
--    22934
--    (2.83 secs, 3,413,414,872 bytes)
--    λ> nSubnumerosPares2 (2^(10^3))
--    22934
--    (0.01 secs, 0 bytes)

import Data.List ( genericLength

, inits

, tails

)

subnumerosPares :: Integer -> [Integer]

subnumerosPares n =

filter even (subnumeros n)

-- (subnumeros n) es la lista de los subnúmeros de n. Por ejemplo,

-- subnumeros 254 == [2,25,5,254,54,4]

subnumeros :: Integer -> [Integer]

subnumeros n =

[read x | x <- sublistas (show n)]

-- (sublistas xs) es la lista de las sublistas de xs. Por ejemplo,

-- sublistas "abc" == ["a","ab","b","abc","bc","c"]

sublistas :: [a] -> [[a]]

sublistas xs =

concat [init (tails ys) | ys <- tail (inits xs)]

-- 1ª definición

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

nSubnumerosPares :: Integer -> Integer

nSubnumerosPares =

genericLength . subnumerosPares

-- 2ª definición

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

nSubnumerosPares2 :: Integer -> Integer

nSubnumerosPares2 =

sum . posicionesDigitosPares

-- (posicionesDigitosPares x) es la lista de las posiciones de los

-- dígitos pares de x. Por ejemplo,

-- posicionesDigitosPares 254 == [1,3]

posicionesDigitosPares :: Integer -> [Integer]

posicionesDigitosPares x =

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

, y `elem` "02468"]

-- Comparación de eficiencia

-- λ> nSubnumerosPares (2^(10^3))

-- 22934

-- (2.83 secs, 3,413,414,872 bytes)

-- λ> nSubnumerosPares2 (2^(10^3))

-- 22934

-- (0.01 secs, 0 bytes)

Elementos con su doble en el conjunto

PorJosé A. Alonso 17-abril-201724-abril-2017

Definir la función

   conDoble :: [Int] -> [Int]

1	conDoble :: [Int] -> [Int]

tal que (conDoble xs) es la lista de los elementos del conjunto xs (representado como una lista sin elementos repetidos) cuyo doble pertenece a xs. Por ejemplo,

   conDoble [1, 4, 3, 2, 9, 7, 18, 22]  ==  [1,2,9]
   conDoble [2, 4, 8, 10]               ==  [2,4]
   conDoble [7, 5, 11, 13, 1, 3]        ==  []
   length (conDoble4 [1..10^6])         ==  500000

conDoble [1, 4, 3, 2, 9, 7, 18, 22] == [1,2,9]

conDoble [2, 4, 8, 10] == [2,4]

conDoble [7, 5, 11, 13, 1, 3] == []

length (conDoble4 [1..10^6]) == 500000

Referencia: Basado en el problema Doubles de POJ (Peking University Online Judge System).

Soluciones

import Data.List (intersect, sort)
import qualified Data.Set as S

-- 1ª Definición
conDoble :: [Int] -> [Int]
conDoble xs =
  [x | x <- xs, 2 * x `elem` xs]

-- 2ª Definición
conDoble2 :: [Int] -> [Int]
conDoble2 xs = aux (sort xs)
  where aux [] = []
        aux (y:ys) | 2 * y `elem` xs = y : aux ys
                   | otherwise       = aux ys

-- 3ª definición
conDoble3 :: [Int] -> [Int]
conDoble3 xs =
  sort (map (`div` 2) (xs `intersect` (map (*2) xs)))

-- 4ª definición
conDoble4 :: [Int] -> [Int]
conDoble4 xs =
  S.toList (S.map (`div` 2) (ys `S.intersection` (S.map (*2) ys)))
  where ys = S.fromList xs

-- Comparación de eficiencia
--    λ> length (conDoble [1..10^4])
--    5000
--    (3.27 secs, 0 bytes)
--    λ> length (conDoble2 [1..10^4])
--    5000
--    (3.42 secs, 0 bytes)
--    λ> length (conDoble3 [1..10^4])
--    5000
--    (4.78 secs, 0 bytes)
--    λ> length (conDoble4 [1..10^4])
--    5000
--    (0.02 secs, 0 bytes)

import Data.List (intersect, sort)

import qualified Data.Set as S

-- 1ª Definición

conDoble :: [Int] -> [Int]

conDoble xs =

[x | x <- xs, 2 * x `elem` xs]

-- 2ª Definición

conDoble2 :: [Int] -> [Int]

conDoble2 xs = aux (sort xs)

where aux [] = []

aux (y:ys) | 2 * y `elem` xs = y : aux ys

| otherwise = aux ys

-- 3ª definición

conDoble3 :: [Int] -> [Int]

conDoble3 xs =

sort (map (`div` 2) (xs `intersect` (map (*2) xs)))

-- 4ª definición

conDoble4 :: [Int] -> [Int]

conDoble4 xs =

S.toList (S.map (`div` 2) (ys `S.intersection` (S.map (*2) ys)))

where ys = S.fromList xs

-- Comparación de eficiencia

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

-- 5000

-- (3.27 secs, 0 bytes)

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

-- 5000

-- (3.42 secs, 0 bytes)

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

-- 5000

-- (4.78 secs, 0 bytes)

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

-- 5000

-- (0.02 secs, 0 bytes)

El problema de las N torres

PorJosé A. Alonso 10-abril-201725-abril-2021

El problema de las N torres consiste en colocar N torres en un tablero con N filas y N columnas de forma que no haya dos torres en la misma fila ni en la misma columna.

Cada solución del problema de puede representar mediante una matriz con ceros y unos donde los unos representan las posiciones ocupadas por las torres y los ceros las posiciones libres. Por ejemplo,

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

( 0 1 0 )

( 1 0 0 )

( 0 0 1 )

representa una solución del problema de las 3 torres.

Definir las funciones

   torres  :: Int -> [Matrix Int]
   nTorres :: Int -> Integer

1 2	torres :: Int -> [Matrix Int] nTorres :: Int -> Integer

tales que
+ (torres n) es la lista de las soluciones del problema de las n torres. Por ejemplo,

      λ> torres 3
      [( 1 0 0 )
       ( 0 1 0 )
       ( 0 0 1 )
      ,( 1 0 0 )
       ( 0 0 1 )
       ( 0 1 0 )
      ,( 0 1 0 )
       ( 1 0 0 )
       ( 0 0 1 )
      ,( 0 1 0 )
       ( 0 0 1 )
       ( 1 0 0 )
      ,( 0 0 1 )
       ( 1 0 0 )
       ( 0 1 0 )
      ,( 0 0 1 )
       ( 0 1 0 )
       ( 1 0 0 )
      ]

λ> torres 3

[( 1 0 0 )

( 0 1 0 )

( 0 0 1 )

,( 1 0 0 )

( 0 0 1 )

( 0 1 0 )

,( 0 1 0 )

( 1 0 0 )

( 0 0 1 )

,( 0 1 0 )

( 0 0 1 )

( 1 0 0 )

,( 0 0 1 )

( 1 0 0 )

( 0 1 0 )

,( 0 0 1 )

( 0 1 0 )

( 1 0 0 )

]

(nTorres n) es el número de soluciones del problema de las n torres. Por ejemplo,

      λ> nTorres 3
      6
      λ> length (show (nTorres (10^4)))
      35660

λ> nTorres 3

λ> length (show (nTorres (10^4)))

35660

Soluciones

import Data.List (genericLength, sort, permutations)
import Data.Matrix 

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

torres1 :: Int -> [Matrix Int]
torres1 n = 
    [permutacionAmatriz n p | p <- sort (permutations [1..n])]

permutacionAmatriz :: Int -> [Int] -> Matrix Int
permutacionAmatriz n p =
    matrix n n f
    where f (i,j) | (i,j) `elem` posiciones = 1
                  | otherwise               = 0
          posiciones = zip [1..n] p    

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

torres2 :: Int -> [Matrix Int]
torres2 = map fromLists . permutations . toLists . identity

-- El cálculo con la definición anterior es:
--    λ> identity 3
--    ( 1 0 0 )
--    ( 0 1 0 )
--    ( 0 0 1 )
--    
--    λ> toLists it
--    [[1,0,0],[0,1,0],[0,0,1]]
--    λ> permutations it
--    [[[1,0,0],[0,1,0],[0,0,1]],
--     [[0,1,0],[1,0,0],[0,0,1]],
--     [[0,0,1],[0,1,0],[1,0,0]],
--     [[0,1,0],[0,0,1],[1,0,0]],
--     [[0,0,1],[1,0,0],[0,1,0]],
--     [[1,0,0],[0,0,1],[0,1,0]]]
--    λ> map fromLists it
--    [( 1 0 0 )
--     ( 0 1 0 )
--     ( 0 0 1 )
--    ,( 0 1 0 )
--     ( 1 0 0 )
--     ( 0 0 1 )
--    ,( 0 0 1 )
--     ( 0 1 0 )
--     ( 1 0 0 )
--    ,( 0 1 0 )
--     ( 0 0 1 )
--     ( 1 0 0 )
--    ,( 0 0 1 )
--     ( 1 0 0 )
--     ( 0 1 0 )
--    ,( 1 0 0 )
--     ( 0 0 1 )
--     ( 0 1 0 )
--    ]

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

nTorres1 :: Int -> Integer
nTorres1 = genericLength . torres1

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

nTorres2 :: Int -> Integer
nTorres2 n = product [1..fromIntegral n]

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

--    λ> nTorres1 9
--    362880
--    (4.22 secs, 693,596,128 bytes)
--    λ> nTorres2 9
--    362880
--    (0.00 secs, 0 bytes)

import Data.List (genericLength, sort, permutations)

import Data.Matrix

-- 1ª definición de torres

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

torres1 :: Int -> [Matrix Int]

torres1 n =

[permutacionAmatriz n p | p <- sort (permutations [1..n])]

permutacionAmatriz :: Int -> [Int] -> Matrix Int

permutacionAmatriz n p =

matrix n n f

where f (i,j) | (i,j) `elem` posiciones = 1

| otherwise = 0

posiciones = zip [1..n] p

-- 2ª definición de torres

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

torres2 :: Int -> [Matrix Int]

torres2 = map fromLists . permutations . toLists . identity

-- El cálculo con la definición anterior es:

-- λ> identity 3

-- ( 1 0 0 )

-- ( 0 1 0 )

-- ( 0 0 1 )

-- λ> toLists it

-- [[1,0,0],[0,1,0],[0,0,1]]

-- λ> permutations it

-- [[[1,0,0],[0,1,0],[0,0,1]],

-- [[0,1,0],[1,0,0],[0,0,1]],

-- [[0,0,1],[0,1,0],[1,0,0]],

-- [[0,1,0],[0,0,1],[1,0,0]],

-- [[0,0,1],[1,0,0],[0,1,0]],

-- [[1,0,0],[0,0,1],[0,1,0]]]

-- λ> map fromLists it

-- [( 1 0 0 )

-- ( 0 1 0 )

-- ( 0 0 1 )

-- ,( 0 1 0 )

-- ( 1 0 0 )

-- ( 0 0 1 )

-- ,( 0 0 1 )

-- ( 0 1 0 )

-- ( 1 0 0 )

-- ,( 0 1 0 )

-- ( 0 0 1 )

-- ( 1 0 0 )

-- ,( 0 0 1 )

-- ( 1 0 0 )

-- ( 0 1 0 )

-- ,( 1 0 0 )

-- ( 0 0 1 )

-- ( 0 1 0 )

-- ]

-- 1ª definición de nTorres

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

nTorres1 :: Int -> Integer

nTorres1 = genericLength . torres1

-- 2ª definición de nTorres

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

nTorres2 :: Int -> Integer

nTorres2 n = product [1..fromIntegral n]

-- Comparación de eficiencia

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

-- λ> nTorres1 9

-- 362880

-- (4.22 secs, 693,596,128 bytes)

-- λ> nTorres2 9

-- 362880

-- (0.00 secs, 0 bytes)

Puntos alcanzables en un mapa

PorJosé A. Alonso 24-marzo-201725-abril-2021

Un mapa con dos tipos de regiones (por ejemplo, tierra y mar) se puede representar mediante una matriz de ceros y unos.

Para los ejemplos usaremos los mapas definidos por

   type Punto = (Int,Int) 
   type Mapa  = Array Punto Int
   
   mapa1, mapa2 :: Mapa
   mapa1 = listArray ((1,1),(3,4))
                     [1,1,0,0,
                      0,1,0,0,
                      1,0,0,0]
   mapa2 = listArray ((1,1),(10,20))
                     [1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
                      1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,1,
                      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,
                      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,
                      1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,
                      0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
                      0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
                      1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,
                      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
                      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1]

type Punto = (Int,Int)

type Mapa = Array Punto Int

mapa1, mapa2 :: Mapa

mapa1 = listArray ((1,1),(3,4))

[1,1,0,0,

0,1,0,0,

1,0,0,0]

mapa2 = listArray ((1,1),(10,20))

[1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,

1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,1,

1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,

1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,

0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,

0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,

1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,

1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,

1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1]

Definir las funciones

   alcanzables :: Mapa -> Punto -> [Punto]
   esAlcanzable :: Mapa -> Punto -> Punto -> Bool

1 2	alcanzables :: Mapa -> Punto -> [Punto] esAlcanzable :: Mapa -> Punto -> Punto -> Bool

tales que

(alcanzables p) es la lista de los puntos de mapa m que se pueden alcanzar a partir del punto p moviéndose en la misma región que p (es decir, a través de ceros si el elemento de m en p es un cero o a través de unos, en caso contrario) y los movimientos permitidos son ir hacia el norte, sur este u oeste (pero no en diagonal). Por ejemplo,

     alcanzables mapa1 (1,1)  ==  [(2,2),(1,2),(1,1)]
     alcanzables mapa1 (1,2)  ==  [(2,2),(1,1),(1,2)]
     alcanzables mapa1 (1,3)  ==  [(3,2),(3,4),(3,3),(2,3),(2,4),(1,4),(1,3)]
     alcanzables mapa1 (3,1)  ==  [(3,1)]

alcanzables mapa1 (1,1) == [(2,2),(1,2),(1,1)]

alcanzables mapa1 (1,2) == [(2,2),(1,1),(1,2)]

alcanzables mapa1 (1,3) == [(3,2),(3,4),(3,3),(2,3),(2,4),(1,4),(1,3)]

alcanzables mapa1 (3,1) == [(3,1)]

(esAlcanzable m p1 p2) se verifica si el punto p1 es alcanzable desde el p1 en el mapa m. Por ejemplo,

     esAlcanzable mapa1 (1,4) (3,2)    ==  True
     esAlcanzable mapa1 (1,4) (3,1)    ==  False
     esAlcanzable mapa2 (2,3) (8,16)   ==  True
     esAlcanzable mapa2 (8,1) (7,3)    ==  True
     esAlcanzable mapa2 (1,1) (10,20)  ==  False

esAlcanzable mapa1 (1,4) (3,2) == True

esAlcanzable mapa1 (1,4) (3,1) == False

esAlcanzable mapa2 (2,3) (8,16) == True

esAlcanzable mapa2 (8,1) (7,3) == True

esAlcanzable mapa2 (1,1) (10,20) == False

Nota: Este ejercicio está basado en el problema 10 kinds of people de Kattis.

Soluciones

import Data.Array

type Punto = (Int,Int) 
type Mapa  = Array Punto Int

mapa1, mapa2 :: Mapa
mapa1 = listArray ((1,1),(3,4))
                  [1,1,0,0,
                   0,1,0,0,
                   1,0,0,0]
mapa2 = listArray ((1,1),(10,20))
                  [1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
                   1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,1,
                   1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,
                   1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,
                   1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,
                   0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
                   0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
                   1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,
                   1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
                   1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1]

alcanzables :: Mapa -> Punto -> [Punto]
alcanzables mapa p = aux [p] []
  where region = mapa ! p
        (_,(m,n)) = bounds mapa
        vecinos (i,j) = [(a,b) | (a,b) <- [(i,j+1),(i,j-1),(i+1,j),(i-1,j)]
                               , 1 <= a && a <= m
                               , 1 <= b && b <= n  
                               , mapa ! (a,b) == region]
        aux [] ys = ys
        aux (x:xs) ys
          | x `elem` ys = aux xs ys
          | otherwise   = aux (vecinos x ++ xs) (x:ys)    

esAlcanzable :: Mapa -> Punto -> Punto -> Bool
esAlcanzable m p1 p2 =
  p2 `elem` alcanzables m p1

import Data.Array

type Punto = (Int,Int)

type Mapa = Array Punto Int

mapa1, mapa2 :: Mapa

mapa1 = listArray ((1,1),(3,4))

[1,1,0,0,

0,1,0,0,

1,0,0,0]

mapa2 = listArray ((1,1),(10,20))

[1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,

1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,1,

1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,

1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,

0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,

0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,

1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,

1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,

1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1]

alcanzables :: Mapa -> Punto -> [Punto]

alcanzables mapa p = aux [p] []

where region = mapa ! p

(_,(m,n)) = bounds mapa

vecinos (i,j) = [(a,b) | (a,b) <- [(i,j+1),(i,j-1),(i+1,j),(i-1,j)]

, 1 <= a && a <= m

, 1 <= b && b <= n

, mapa ! (a,b) == region]

aux [] ys = ys

aux (x:xs) ys

| x `elem` ys = aux xs ys

| otherwise = aux (vecinos x ++ xs) (x:ys)

esAlcanzable :: Mapa -> Punto -> Punto -> Bool

esAlcanzable m p1 p2 =

p2 `elem` alcanzables m p1

Por 3 o más 5

PorJosé A. Alonso 16-marzo-201720-enero-2019

El enunciado del problema Por 3 o más 5 de ¡Acepta el reto! es el siguiente

Cuenta la leyenda que un famoso matemático, tras aprender a sumar y multiplicar a la tierna edad de 3 años en apenas 5 días, se dio cuenta de que, empezando por 1, podía generar un montón de números sin más que multiplicar por 3 o sumar 5 a alguno de los que ya hubiera generado antes.

Por ejemplo, el 23 (edad a la que se casaría) lo obtuvo así: ((1 + 5) × 3) + 5
Por su parte el 77 (edad a la que tendría su primer bisnieto) lo consiguió: (((1 × 3 + 5) × 3) × 3) + 5

Por mucho que lo intentó, algunos números, sin embargo, resultaron ser imposibles de obtener, como por ejemplo el 5, el 7 o el 15.

Se dice que un número es generable si se puede escribir como una sucesión (quizá vacía) de multiplicaciones por 3 y sumas de 5 al número 1.

Definir las siguientes funciones

   generables     :: [Integer]
   generable      :: Integer -> Bool
   arbolGenerable :: Integer -> Tree Integer

generables :: [Integer]

generable :: Integer -> Bool

arbolGenerable :: Integer -> Tree Integer

tales que

generables es la sucesión de los números generables. Por ejemplo,

     λ> take 20 generables
     [1,3,6,8,9,11,13,14,16,18,19,21,23,24,26,27,28,29,31,32]
     λ> generables !! (10^6)
     1250008

λ> take 20 generables

[1,3,6,8,9,11,13,14,16,18,19,21,23,24,26,27,28,29,31,32]

λ> generables !! (10^6)

1250008

(generable x) se verifica si x es generable. Por ejemplo,

     generable 23       ==  True
     generable 77       ==  True
     generable 15       ==  False
     generable 1250008  ==  True
     generable 1250010  ==  False

generable 23 == True

generable 77 == True

generable 15 == False

generable 1250008 == True

generable 1250010 == False

(arbolGenerable x) es el árbol de los números generables menores o iguales a x. Por ejemplo,

     λ> putStrLn (drawTree (fmap show (arbolGenerable 11)))
     1
     |
     +- 3
     |  |
     |  +- 9
     |  |
     |  `- 8
     |
     `- 6
        |
        `- 11

λ> putStrLn (drawTree (fmap show (arbolGenerable 11)))

+- 3

| |

| +- 9

| |

| `- 8

`- 6

`- 11

Soluciones

import Graphics.Gnuplot.Simple

generables :: [Integer]
generables = 1 : mezcla [3 * x | x <- generables]
                        [5 + x | x <- generables]

-- (mezcla xs ys) es la lista ordenada obtenida mezclando las dos listas
-- ordenadas xs e ys, suponiendo que ambas son infinitas. Por ejemplo,
--    take 10 (mezcla [2,12..] [5,15..])  ==  [2,5,12,15,22,25,32,35,42,45]
--    take 10 (mezcla [2,22..] [5,15..])  ==  [2,5,15,22,25,35,42,45,55,62]
mezcla :: Ord a => [a] -> [a] -> [a]
mezcla us@(x:xs) vs@(y:ys)
  | x < y     = x : mezcla xs vs
  | x == y    = x : mezcla xs ys
  | otherwise = y : mezcla us ys

generable :: Integer -> Bool
generable x =
  x == head (dropWhile (<x) generables)

-- 2ª definición
generable2 :: Integer -> Bool
generable2 1 = True
generable2 x =    (x `mod` 3 == 0 && generable2 (x `div` 3))
               || (x > 5 && generable2 (x - 5))

generables2 :: [Integer] 
generables2 = filter generable2 [1..]

arbolGenerable :: Integer -> Tree Integer
arbolGenerable n = aux 1
  where aux x
          | 3*x <= n && 5+x <= n = Node x [aux (3*x), aux (5+x)] 
          | 3*x <= n             = Node x [aux (3*x)]
          | 5+x <= n             = Node x [aux (5+x)]
          | otherwise            = Node x [] 

-- 3ª definición
generable3 :: Integer -> Bool
generable3 x =
  x `elem` arbolGenerable x

import Graphics.Gnuplot.Simple

generables :: [Integer]

generables = 1 : mezcla [3 * x | x <- generables]

[5 + x | x <- generables]

-- (mezcla xs ys) es la lista ordenada obtenida mezclando las dos listas

-- ordenadas xs e ys, suponiendo que ambas son infinitas. Por ejemplo,

-- take 10 (mezcla [2,12..] [5,15..]) == [2,5,12,15,22,25,32,35,42,45]

-- take 10 (mezcla [2,22..] [5,15..]) == [2,5,15,22,25,35,42,45,55,62]

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

mezcla us@(x:xs) vs@(y:ys)

| x < y = x : mezcla xs vs

| x == y = x : mezcla xs ys

| otherwise = y : mezcla us ys

generable :: Integer -> Bool

generable x =

x == head (dropWhile (<x) generables)

-- 2ª definición

generable2 :: Integer -> Bool

generable2 1 = True

generable2 x = (x `mod` 3 == 0 && generable2 (x `div` 3))

|| (x > 5 && generable2 (x - 5))

generables2 :: [Integer]

generables2 = filter generable2 [1..]

arbolGenerable :: Integer -> Tree Integer

arbolGenerable n = aux 1

where aux x

| 3*x <= n && 5+x <= n = Node x [aux (3*x), aux (5+x)]

| 3*x <= n = Node x [aux (3*x)]

| 5+x <= n = Node x [aux (5+x)]

| otherwise = Node x []

-- 3ª definición

generable3 :: Integer -> Bool

generable3 x =

x `elem` arbolGenerable x

Números cubifinitos

PorJosé A. Alonso 15-marzo-201721-enero-2020

El enunciado del problema Números cubifinitos de ¡Acepta el reto! es el siguiente

Se dice que un número es cubifinito cuando al elevar todos sus dígitos al cubo y sumarlos el resultado o bien es 1 o bien es un número cubifinito.

Por ejemplo, el número 1243 es cubifinito, pues al elevar todos sus dígitos al cubo obtenemos 100 que es cubifinito.

Por su parte, el 513 no es cubifinito, pues al elevar al cubo sus dígitos conseguimos el 153 que nunca podrá ser cubifinito, pues la suma de los cubos de sus dígitos vuelve a dar 153.

Definir las funciones

   esCubifinito :: Int -> Bool
   grafica :: Int -> IO ()

1 2	esCubifinito :: Int -> Bool grafica :: Int -> IO ()

tales que

(esCubifinito n) se verifica si n es un número cubifinito. Por ejemplo,

     esCubifinito 1      ==  True
     esCubifinito 10     ==  True
     esCubifinito 1243   ==  True
     esCubifinito 87418  ==  True
     esCubifinito 513    ==  False

esCubifinito 1 == True

esCubifinito 10 == True

esCubifinito 1243 == True

esCubifinito 87418 == True

esCubifinito 513 == False

(grafica n) dibuja la gráfica de la sucesión de los primeros n números cubifinitos. Por ejemplo, al evaluar (grafica 50) se dibuja

Soluciones

import Graphics.Gnuplot.Simple

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

esCubifinito :: Int -> Bool
esCubifinito n = aux [n]
  where aux (n:ns) | n == 1      = True
                   | n `elem` ns = False
                   | otherwise   = aux (sumaCubosDigitos n : n : ns)

-- (sumaCubosDigitos b) es la suma de los cubos de los dígitos de n. Por
-- ejemplo, 
--    sumaCubosDigitos 513  ==  153
sumaCubosDigitos :: Int -> Int
sumaCubosDigitos = sum . map (^3) . digitos

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

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

esCubifinito2 :: Int -> Bool
esCubifinito2 n = primerRepetido (orbita n) == 1

-- (orbita n) es la lista cuyo primer elemento es n y los siguientes se
-- obtienen sumando los cubos de los digitos del elemento anterior. Por
-- ejemplo,  
--    take 9 (orbita 2)  ==  [2,8,512,134,92,737,713,371,371]
orbita :: Int -> [Int]
orbita n = iterate sumaCubosDigitos n

-- (primerRepetido xs) es el primer elemento repetido de la lista
--  xs. Por ejemplo, 
--    primerRepetido [3,7,5,7,2]  ==  7
primerRepetido :: Eq a => [a] -> a
primerRepetido xs = aux xs []
  where
    aux (x:xs') ys | x `elem` ys = x
                   | otherwise   = aux xs' (x:ys) 

grafica :: Int -> IO ()
grafica n = 
    plotList [Key Nothing, PNG "Numeros_cubifinitos.png"]
             (zip [1..n] [x | x <- [1..], esCubifinito x])

import Graphics.Gnuplot.Simple

-- 1ª solución

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

esCubifinito :: Int -> Bool

esCubifinito n = aux [n]

where aux (n:ns) | n == 1 = True

| n `elem` ns = False

| otherwise = aux (sumaCubosDigitos n : n : ns)

-- (sumaCubosDigitos b) es la suma de los cubos de los dígitos de n. Por

-- ejemplo,

-- sumaCubosDigitos 513 == 153

sumaCubosDigitos :: Int -> Int

sumaCubosDigitos = sum . map (^3) . digitos

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

-- digitos 513 == [5,1,3]

digitos :: Int -> [Int]

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

-- 2ª solución

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

esCubifinito2 :: Int -> Bool

esCubifinito2 n = primerRepetido (orbita n) == 1

-- (orbita n) es la lista cuyo primer elemento es n y los siguientes se

-- obtienen sumando los cubos de los digitos del elemento anterior. Por

-- ejemplo,

-- take 9 (orbita 2) == [2,8,512,134,92,737,713,371,371]

orbita :: Int -> [Int]

orbita n = iterate sumaCubosDigitos n

-- (primerRepetido xs) es el primer elemento repetido de la lista

-- xs. Por ejemplo,

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

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

primerRepetido xs = aux xs []

where

aux (x:xs') ys | x `elem` ys = x

| otherwise = aux xs' (x:ys)

grafica :: Int -> IO ()

grafica n =

plotList [Key Nothing, PNG "Numeros_cubifinitos.png"]

(zip [1..n] [x | x <- [1..], esCubifinito x])

Sucesiones alícuotas

PorJosé A. Alonso 28-febrero-20177-marzo-2017

La sucesión alícuota de un número x es la sucesión cuyo primer término es x y cada otro término es la suma de los divisores propios del término anterior. Por ejemplo, la sucesión alícuota de 10 es [10,8,7,1,0,0,0] ya que

   la suma de los divisores propios de 10 es 5 + 2 + 1 = 8
   la suma de los divisores propios de  8 es 4 + 2 + 1 = 7
   la suma de los divisores propios de  7 es 1
   la suma de los divisores propios de  1 es 0

la suma de los divisores propios de 10 es 5 + 2 + 1 = 8

la suma de los divisores propios de 8 es 4 + 2 + 1 = 7

la suma de los divisores propios de 7 es 1

la suma de los divisores propios de 1 es 0

Definir la función

   sucAlicuota :: Integer -> [Integer]

1	sucAlicuota :: Integer -> [Integer]

tal que (sucAlicuota x) es la sucesión alícuota de x. Por ejemplo,

   take 6 (sucAlicuota 10)       ==  [10,8,7,1,0,0]
   take 6 (sucAlicuota 95)       ==  [95,25,6,6,6,6]
   take 6 (sucAlicuota 220)      ==  [220,284,220,284,220,284]
   sucAlicuota 1184 !! (1+10^7)  ==  1210
   sucAlicuota 276 !! 200        ==  2790456740340877466506

take 6 (sucAlicuota 10) == [10,8,7,1,0,0]

take 6 (sucAlicuota 95) == [95,25,6,6,6,6]

take 6 (sucAlicuota 220) == [220,284,220,284,220,284]

sucAlicuota 1184 !! (1+10^7) == 1210

sucAlicuota 276 !! 200 == 2790456740340877466506

Soluciones

import Math.NumberTheory.ArithmeticFunctions (sigma)

-- 1ª definición
-- =============

sucAlicuota :: Integer -> [Integer]
sucAlicuota x = x : sucAlicuota (sumaDivisoresPropios x)

sumaDivisoresPropios :: Integer -> Integer
sumaDivisoresPropios x =
  sum [y | y <- [1..x-1], x `mod` y == 0]

-- 2ª definición
-- =============

sucAlicuota2 :: Integer -> [Integer]
sucAlicuota2 = iterate (sum . divisoresPropios)

divisoresPropios :: Integer -> [Integer]
divisoresPropios x = [y | y <- [1..x-1], x `mod` y == 0]

-- 3ª definición
-- =============

sucAlicuota3 :: Integer -> [Integer]
sucAlicuota3 x = aux x []
  where aux y ys | y `elem` ys = us ++ cycle zs
                 | otherwise   = aux (sumaDivisoresPropios y) (y:ys)
          where us = reverse ys
                zs = dropWhile (/=y) us

-- 4ª definición
-- =============

sucAlicuota4 :: Integer -> [Integer]
sucAlicuota4 x = x : sucAlicuota4 (sumaDivisoresPropios4 x)

sumaDivisoresPropios4 :: Integer -> Integer
sumaDivisoresPropios4 x =
  sigma 1 x - x

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

--    λ> sucAlicuota 1184 !! (1+10^3)
--    1210
--    (2.02 secs, 261,081,688 bytes)
--    λ> sucAlicuota2 1184 !! (1+10^3)
--    1210
--    (2.02 secs, 245,485,568 bytes)
--    λ> sucAlicuota3 1184 !! (1+10^3)
--    1210
--    (0.02 secs, 0 bytes)
--    λ> sucAlicuota4 1184 !! (1+10^3)
--    1210
--    (0.05 secs, 0 bytes)

import Math.NumberTheory.ArithmeticFunctions (sigma)

-- 1ª definición

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

sucAlicuota :: Integer -> [Integer]

sucAlicuota x = x : sucAlicuota (sumaDivisoresPropios x)

sumaDivisoresPropios :: Integer -> Integer

sumaDivisoresPropios x =

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

-- 2ª definición

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

sucAlicuota2 :: Integer -> [Integer]

sucAlicuota2 = iterate (sum . divisoresPropios)

divisoresPropios :: Integer -> [Integer]

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

-- 3ª definición

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

sucAlicuota3 :: Integer -> [Integer]

sucAlicuota3 x = aux x []

where aux y ys | y `elem` ys = us ++ cycle zs

| otherwise = aux (sumaDivisoresPropios y) (y:ys)

where us = reverse ys

zs = dropWhile (/=y) us

-- 4ª definición

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

sucAlicuota4 :: Integer -> [Integer]

sucAlicuota4 x = x : sucAlicuota4 (sumaDivisoresPropios4 x)

sumaDivisoresPropios4 :: Integer -> Integer

sumaDivisoresPropios4 x =

sigma 1 x - x

-- Comparación de eficiencia

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

-- λ> sucAlicuota 1184 !! (1+10^3)

-- 1210

-- (2.02 secs, 261,081,688 bytes)

-- λ> sucAlicuota2 1184 !! (1+10^3)

-- 1210

-- (2.02 secs, 245,485,568 bytes)

-- λ> sucAlicuota3 1184 !! (1+10^3)

-- 1210

-- (0.02 secs, 0 bytes)

-- λ> sucAlicuota4 1184 !! (1+10^3)

-- 1210

-- (0.05 secs, 0 bytes)

Sucesión de Cantor de números innombrables

PorJosé A. Alonso 3-febrero-201725-abril-2021

Un número es innombrable si es divisible por 7 o alguno de sus dígitos es un 7. Un juego infantil consiste en contar saltándose los números innombrables:

   1 2 3 4 5 6 ( ) 8 9 10 11 12 13 ( ) 15 16 ( ) 18 ...

1	1 2 3 4 5 6 ( ) 8 9 10 11 12 13 ( ) 15 16 ( ) 18 ...

La sucesión de Cantor se obtiene llenando los huecos de la sucesión anterior
como se indica a continuación:

  1 2 3 4 5 6 (1) 8 9 10 11 12 13 (2) 15 16 (3) 18 19 20 (4) 22 23
  24 25 26 (5) (6) 29 30 31 32 33 34 (1) 36 (8) 38 39 40 41  (9) 43
  44 45 46 (10) 48 (11) 50 51 52 53 54 55 (12) (13) 58 59 60 61 62
  (2) 64 65 66 (15) 68 69 (16) (3) (18) (19) (20) (4) (22) (23) (24)
  (25) 80 81 82 83 (26) 85 86 (5) 88 89 90 (6) 92 93 94 95 96 (29)
  (30) 99 100

1 2 3 4 5 6 (1) 8 9 10 11 12 13 (2) 15 16 (3) 18 19 20 (4) 22 23

24 25 26 (5) (6) 29 30 31 32 33 34 (1) 36 (8) 38 39 40 41 (9) 43

44 45 46 (10) 48 (11) 50 51 52 53 54 55 (12) (13) 58 59 60 61 62

(2) 64 65 66 (15) 68 69 (16) (3) (18) (19) (20) (4) (22) (23) (24)

(25) 80 81 82 83 (26) 85 86 (5) 88 89 90 (6) 92 93 94 95 96 (29)

(30) 99 100

Definir la sucesión

   sucCantor :: [Integer]

1	sucCantor :: [Integer]

cuyos elementos son los términos de la sucesión de Cantor. Por ejemplo,

   λ> take 100 sucCantor
   [1,2,3,4,5,6, 1 ,8,9,10,11,12,13, 2, 15,16, 3, 18,19,20, 4,
    22,23,24,25,26, 5 , 6 ,29,30,31,32,33,34, 1 ,36 , 8 ,38,39,
    40,41, 9 ,43,44,45,46, 10 ,48, 11 ,50,51,52,53,54,55 , 12 ,
    13, 58,59,60,61,62, 2 ,64,65,66, 15 ,68,69, 16 , 3 , 18, 19,
    20, 4, 22, 23, 24 ,25 ,80,81,82,83, 26 ,85,86, 5 ,88,89,90,
    6, 92,93,94,95,96, 29, 30 ,99,100]

   λ> sucCantor2 !! (5+10^6)
   544480

   λ> sucCantor2 !! (6+10^6)
   266086

λ> take 100 sucCantor

[1,2,3,4,5,6, 1 ,8,9,10,11,12,13, 2, 15,16, 3, 18,19,20, 4,

22,23,24,25,26, 5 , 6 ,29,30,31,32,33,34, 1 ,36 , 8 ,38,39,

40,41, 9 ,43,44,45,46, 10 ,48, 11 ,50,51,52,53,54,55 , 12 ,

13, 58,59,60,61,62, 2 ,64,65,66, 15 ,68,69, 16 , 3 , 18, 19,

20, 4, 22, 23, 24 ,25 ,80,81,82,83, 26 ,85,86, 5 ,88,89,90,

6, 92,93,94,95,96, 29, 30 ,99,100]

λ> sucCantor2 !! (5+10^6)

544480

λ> sucCantor2 !! (6+10^6)

266086

Soluciones

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

sucCantor1 :: [Integer]
sucCantor1 = map fst $ scanl f (1,0) [2..]
  where f (a,i) x
          | esInnombrable x = (sucCantor1 !! i, i+1)
          | otherwise       = (x,i)


esInnombrable :: Integer -> Bool
esInnombrable x =
  rem x 7 == 0 || '7' `elem` show x

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

sucCantor2 :: [Integer]
sucCantor2 = aux 0 1
  where aux i x
          | esInnombrable x = sucCantor2 !! i : aux (i+1) (x+1)
          | otherwise       = x : aux i (x+1)

-- 1ª solución

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

sucCantor1 :: [Integer]

sucCantor1 = map fst $ scanl f (1,0) [2..]

where f (a,i) x

| esInnombrable x = (sucCantor1 !! i, i+1)

| otherwise = (x,i)

esInnombrable :: Integer -> Bool

esInnombrable x =

rem x 7 == 0 || '7' `elem` show x

-- 2ª solución

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

sucCantor2 :: [Integer]

sucCantor2 = aux 0 1

where aux i x

| esInnombrable x = sucCantor2 !! i : aux (i+1) (x+1)

| otherwise = x : aux i (x+1)

Referencia

Basado en Cantor’s unspeakable numbers de
CodeGolf.

Eliminación de triplicados

PorJosé A. Alonso 31-enero-20178-febrero-2017

Definir la función

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

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

tal que (sinTriplicados xs) es la lista obtenida dejando en xs sólo las dos primeras ocurrencias de cada uno de sus elementos. Por ejemplo,

   sinTriplicados "aaabcbccdbabdcd"  ==  "aabcbcdd"
   sinTriplicados "xxxxx"            ==  "xx"
   sinTriplicados "abcabc"           ==  "abcabc"
   sinTriplicados "abcdabcaba"       ==  "abcdabc"
   sinTriplicados "abacbadcba"       ==  "abacbdc"
   sinTriplicados "aaabcbccdbabdcd"  ==  "aabcbcdd"
   sinTriplicados (show (5^4^3))     ==  "54210108624757363989"
   sinTriplicados (show (8^8^8))     ==  "60145207536139279488"

sinTriplicados "aaabcbccdbabdcd" == "aabcbcdd"

sinTriplicados "xxxxx" == "xx"

sinTriplicados "abcabc" == "abcabc"

sinTriplicados "abcdabcaba" == "abcdabc"

sinTriplicados "abacbadcba" == "abacbdc"

sinTriplicados "aaabcbccdbabdcd" == "aabcbcdd"

sinTriplicados (show (5^4^3)) == "54210108624757363989"

sinTriplicados (show (8^8^8)) == "60145207536139279488"

Soluciones

import Data.List (delete)

sinTriplicados :: Eq a => [a] -> [a]
sinTriplicados xs = aux xs [] []
  where aux [] _ _ = []
        aux (x:xs) ys zs
          | x `elem` zs = aux xs ys zs
          | x `elem` ys = x : aux xs (delete x ys) (x:zs)
          | otherwise   = x : aux xs (x:ys) zs

import Data.List (delete)

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

sinTriplicados xs = aux xs [] []

where aux [] _ _ = []

aux (x:xs) ys zs

| x `elem` zs = aux xs ys zs

| x `elem` ys = x : aux xs (delete x ys) (x:zs)

| otherwise = x : aux xs (x:ys) zs

Máximo producto de pares en la lista

PorJosé A. Alonso 30-enero-201726-marzo-2022

Definir la función

  maximoProducto :: [Int] -> Maybe Int

1	maximoProducto :: [Int] -> Maybe Int

tal que (maximoProducto xs) es el mayor elemento de xs que se puede escribir
como producto de dos elementos distintos de xs o Nothing, en el caso de que
ningún elemento de xs se pueda escribir como producto de dos elementos
distintos de xs, donde xs es una lista de números mayores que 0. Por ejemplo,

   maximoProducto [10, 3, 5, 30, 35]       ==  Just 30
   maximoProducto [10, 2, 2, 4, 30, 35]    ==  Just 4
   maximoProducto [17, 2, 1, 35, 30]       ==  Just 35
   maximoProducto [2,4]                    ==  Nothing
   maximoProducto [2, 5, 7, 8]             ==  Nothing
   maximoProducto [10, 2, 4, 30, 35]       ==  Nothing
   maximoProducto [1+2^n | n <- [1..10^6]] ==  Just 4611686018427387905

maximoProducto [10, 3, 5, 30, 35] == Just 30

maximoProducto [10, 2, 2, 4, 30, 35] == Just 4

maximoProducto [17, 2, 1, 35, 30] == Just 35

maximoProducto [2,4] == Nothing

maximoProducto [2, 5, 7, 8] == Nothing

maximoProducto [10, 2, 4, 30, 35] == Nothing

maximoProducto [1+2^n | n <- [1..10^6]] == Just 4611686018427387905

En el primer ejemplo, 30 es el producto de 10 y 3; en el segundo, 4 es el producto de 2 y 2 y en el tercero, 35 es el producto de 1 y 35.

Soluciones

import Data.List (delete, nub, sort)

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

maximoProducto1 :: [Int] -> Maybe Int
maximoProducto1 xs
  | null zs   = Nothing
  | otherwise = Just (head zs)
  where
    ys = reverse (sort xs)
    zs = [y | y <- ys, y `elem` productos xs]

-- (productos xs) es la lista de los números que son productos de dos
-- elementos de xs. Por ejemplo, 
--   productos [4,3,5,2]  ==  [12,20,8,15,6,10]
productos :: [Int] -> [Int]
productos xs =
  nub [y * z | y <- xs, z <- delete y xs]

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

maximoProducto2 :: [Int] -> Maybe Int
maximoProducto2 xs = aux (reverse (sort xs))
  where aux []     = Nothing
        aux (y:ys) | esProducto y xs = Just y
                   | otherwise       = aux ys

esProducto :: Int -> [Int] -> Bool
esProducto y []     = False
esProducto y (x:xs) = 
  (m == 0 && d `elem` xs) || esProducto y xs
  where (d,m) = divMod y x  

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

--    λ> maximoProducto1 [1..10^4]
--    Just 10000
--    (2.60 secs, 0 bytes)
--    λ> maximoProducto2 [1..10^4]
--    Just 10000
--    (0.01 secs, 0 bytes)

import Data.List (delete, nub, sort)

-- 1ª solución

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

maximoProducto1 :: [Int] -> Maybe Int

maximoProducto1 xs

| null zs = Nothing

| otherwise = Just (head zs)

where

ys = reverse (sort xs)

zs = [y | y <- ys, y `elem` productos xs]

-- (productos xs) es la lista de los números que son productos de dos

-- elementos de xs. Por ejemplo,

-- productos [4,3,5,2] == [12,20,8,15,6,10]

productos :: [Int] -> [Int]

productos xs =

nub [y * z | y <- xs, z <- delete y xs]

-- 2ª solución

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

maximoProducto2 :: [Int] -> Maybe Int

maximoProducto2 xs = aux (reverse (sort xs))

where aux [] = Nothing

aux (y:ys) | esProducto y xs = Just y

| otherwise = aux ys

esProducto :: Int -> [Int] -> Bool

esProducto y [] = False

esProducto y (x:xs) =

(m == 0 && d `elem` xs) || esProducto y xs

where (d,m) = divMod y x

-- Comparación de eficiencia

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

-- λ> maximoProducto1 [1..10^4]

-- Just 10000

-- (2.60 secs, 0 bytes)

-- λ> maximoProducto2 [1..10^4]

-- Just 10000

-- (0.01 secs, 0 bytes)

Números super pandigitales

PorJosé A. Alonso 27-diciembre-20163-enero-2017

Un entero positivo n es pandigital en base b si su expresión en base b contiene todos los dígitos de 0 a b-1 al menos una vez. Por ejemplo,

el 2 es pandigital en base 2 porque 2 en base 2 es 10,
el 11 es pandigital en base 3 porque 11 en base 3 es 102 y
el 75 es pandigital en base 4 porque 75 en base 4 es 1023.

Un número n es super pandigital de orden m si es pandigital en todas las bases
desde 2 hasta m. Por ejemplo, 978 es super pandigital de orden 5 pues

en base 2 es: 1111010010
en base 3 es: 1100020
en base 4 es: 33102
en base 5 es: 12403

Definir la función

   superPandigitales :: Integer -> [Integer]

1	superPandigitales :: Integer -> [Integer]

tal que (superPandigitales m) es la lista de los números super pandigitales de orden m. Por ejemplo,

   take 3 (superPandigitales 3) == [11,19,21]
   take 3 (superPandigitales 4) == [75,99,114]
   take 3 (superPandigitales 5) == [978,1070,1138]

take 3 (superPandigitales 3) == [11,19,21]

take 3 (superPandigitales 4) == [75,99,114]

take 3 (superPandigitales 5) == [978,1070,1138]

Soluciones

superPandigitales :: Integer -> [Integer]
superPandigitales m =
  [n | n <- [1..]
     , and [pandigitalBase b n | b <- [2..m]]]

-- (pandigitalBase b n) se verifica si n es pandigital en base la base
-- b. Por ejemplo,
--    pandigitalBase 4 75  ==  True
--    pandigitalBase 4 76  ==  False
pandigitalBase :: Integer -> Integer -> Bool
pandigitalBase b n = [0..b-1] `esSubconjunto` enBase b n

-- (enBase b n) es la lista de los dígitos de n en base b. Por ejemplo,
--    enBase 4 75  ==  [3,2,0,1]
--    enBase 4 76  ==  [0,3,0,1]
enBase :: Integer -> Integer -> [Integer]
enBase b n | n < b     = [n]
           | otherwise = n `mod` b : enBase b (n `div` b)

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

superPandigitales :: Integer -> [Integer]

superPandigitales m =

[n | n <- [1..]

, and [pandigitalBase b n | b <- [2..m]]]

-- (pandigitalBase b n) se verifica si n es pandigital en base la base

-- b. Por ejemplo,

-- pandigitalBase 4 75 == True

-- pandigitalBase 4 76 == False

pandigitalBase :: Integer -> Integer -> Bool

pandigitalBase b n = [0..b-1] `esSubconjunto` enBase b n

-- (enBase b n) es la lista de los dígitos de n en base b. Por ejemplo,

-- enBase 4 75 == [3,2,0,1]

-- enBase 4 76 == [0,3,0,1]

enBase :: Integer -> Integer -> [Integer]

enBase b n | n < b = [n]

| otherwise = n `mod` b : enBase b (n `div` b)

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

-- ejemplo,

-- esSubconjunto [1,5] [5,2,1] == True

-- esSubconjunto [1,5] [5,2,3] == False

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

esSubconjunto xs ys = all (`elem` ys) xs

Selección por posición

PorJosé A. Alonso 19-diciembre-201627-diciembre-2016

Definir la función

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

1	seleccion :: Ord a => [a] -> [Int] -> [a]

tal que (seleccion xs ps) es la lista ordenada de los elementos que ocupan las posiciones indicadas en la lista ps. Por ejemplo,

   seleccion [6,2,4,7] [2,0]      ==  [4,6]
   seleccion ['a'..'z'] [0,2..10] ==  "acegik"

1 2	seleccion [6,2,4,7] [2,0] == [4,6] seleccion ['a'..'z'] [0,2..10] == "acegik"

Soluciones

import Data.List (sort)

-- 1ª definición
seleccion :: Ord a => [a] -> [Int] -> [a]
seleccion xs ps =
  sort [x | (x,n) <- zip xs [0..]
          , n `elem` ps]

-- 2ª definición
seleccion2 :: Ord a => [a] -> [Int] -> [a]
seleccion2 xs = sort . map (xs!!)

import Data.List (sort)

-- 1ª definición

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

seleccion xs ps =

sort [x | (x,n) <- zip xs [0..]

, n `elem` ps]

-- 2ª definición

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

seleccion2 xs = sort . map (xs!!)

Distancia a Erdős

PorJosé A. Alonso 14-diciembre-201621-diciembre-2016

Una de las razones por la que el matemático húngaro Paul Erdős es conocido es por la multitud de colaboraciones que realizó durante toda su carrera, un total de 511. Tal es así que se establece la distancia a Erdős como la distancia que has estado de coautoría con Erdős. Por ejemplo, si eres Paul Erdős tu distancia a Erdős es 0, si has escrito un artículo con Erdős tu distancia es 1, si has escrito un artículo con alguien que ha escrito un artículo con Erdős tu distancia es 2, etc. El objetivo de este problema es definir una función que a partir de una lista de pares de coautores y un número natural n calcular la lista de los matemáticos a una distancia n de Erdős.

Para el problema se considerará la siguiente lista de coautores

   coautores :: [(String,String)]
   coautores =
     [("Paul Erdos","Ernst Straus"),("Paul Erdos","Pascual Jordan"),
      ("Paul Erdos","D. Kleitman"),("Albert Einstein","Ernst Straus"),
      ("John von Newmann","David Hilbert"),("S. Glashow","D. Kleitman"),
      ("John von Newmann","Pascual Jordan"), ("David Pines","D. Bohm"),
      ("Albert Einstein","Otto Stern"),("S. Glashow", "M. Gell-Mann"),
      ("Richar Feynman","M. Gell-Mann"),("M. Gell-Mann","David Pines"),
      ("David Pines","A. Bohr"),("Wolfgang Pauli","Albert Einstein"),
      ("D. Bohm","L. De Broglie"), ("Paul Erdos","J. Conway"),
      ("J. Conway", "P. Doyle"),("Paul Erdos","A. J. Granville"),
      ("A. J. Granville","B. Mazur"),("B. Mazur","Andrew Wiles")]

coautores :: [(String,String)]

coautores =

[("Paul Erdos","Ernst Straus"),("Paul Erdos","Pascual Jordan"),

("Paul Erdos","D. Kleitman"),("Albert Einstein","Ernst Straus"),

("John von Newmann","David Hilbert"),("S. Glashow","D. Kleitman"),

("John von Newmann","Pascual Jordan"), ("David Pines","D. Bohm"),

("Albert Einstein","Otto Stern"),("S. Glashow", "M. Gell-Mann"),

("Richar Feynman","M. Gell-Mann"),("M. Gell-Mann","David Pines"),

("David Pines","A. Bohr"),("Wolfgang Pauli","Albert Einstein"),

("D. Bohm","L. De Broglie"), ("Paul Erdos","J. Conway"),

("J. Conway", "P. Doyle"),("Paul Erdos","A. J. Granville"),

("A. J. Granville","B. Mazur"),("B. Mazur","Andrew Wiles")]

La lista anterior es real y se ha obtenido del artículo Famous trails to Paul Erdős.

Definir la función

   numeroDeErdos :: [(String, String)] -> Int -> [String]

1	numeroDeErdos :: [(String, String)] -> Int -> [String]

tal que (numeroDeErdos xs n) es la lista de lista de los matemáticos de la
lista de coautores xs que se encuentran a una distancia n de Erdős. Por ejemplo,

   λ> numeroDeErdos coautores 0
   ["Paul Erdos"]
   λ> numeroDeErdos coautores 1
   ["Ernst Straus","Pascual Jordan","D. Kleitman","J. Conway","A. J. Granville"]
   λ> numeroDeErdos coautores 2
   ["Albert Einstein","John von Newmann","S. Glashow","P. Doyle","B. Mazur"]

λ> numeroDeErdos coautores 0

["Paul Erdos"]

λ> numeroDeErdos coautores 1

["Ernst Straus","Pascual Jordan","D. Kleitman","J. Conway","A. J. Granville"]

λ> numeroDeErdos coautores 2

["Albert Einstein","John von Newmann","S. Glashow","P. Doyle","B. Mazur"]

Nota: Este ejercicio ha sido propuesto por Enrique Naranjo.

Soluciones

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

coautores :: [(String,String)]
coautores =
  [("Paul Erdos","Ernst Straus"),("Paul Erdos","Pascual Jordan"),
   ("Paul Erdos","D. Kleitman"),("Albert Einstein","Ernst Straus"),
   ("John von Newmann","David Hilbert"),("S. Glashow","D. Kleitman"),
   ("John von Newmann","Pascual Jordan"), ("David Pines","D. Bohm"),
   ("Albert Einstein","Otto Stern"),("S. Glashow", "M. Gell-Mann"),
   ("Richar Feynman","M. Gell-Mann"),("M. Gell-Mann","David Pines"),
   ("David Pines","A. Bohr"),("Wolfgang Pauli","Albert Einstein"),
   ("D. Bohm","L. De Broglie"), ("Paul Erdos","J. Conway"),
   ("J. Conway", "P. Doyle"),("Paul Erdos","A. J. Granville"),
   ("A. J. Granville","B. Mazur"),("B. Mazur","Andrew Wiles")]

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

numeroDeErdos :: [(String, String)] -> Int -> [String]
numeroDeErdos xs n = nivel n (arbolDeErdos xs "Paul Erdos")

-- (arbolDeErdos xs a) es el árbol de coautores de a según la lista de
-- coautores xs. Por ejemplo,
--    λ> arbolDeErdos coautores "Paul Erdos"
--    N "Paul Erdos"
--      [N "Ernst Straus"
--         [N "Albert Einstein"
--           [N "Wolfgang Pauli" [],
--            N "Otto Stern" []]],
--          N "Pascual Jordan"
--            [N "John von Newmann"
--               [N "David Hilbert" []]],
--          N "D. Kleitman"
--            [N "S. Glashow"
--               [N "M. Gell-Mann"
--                  [N "Richar Feynman" [],
--                   N "David Pines"
--                     [N "A. Bohr" [],
--                      N "D. Bohm"
--                        [N "L. De Broglie" []]]]]],
--          N "J. Conway"
--            [N "P. Doyle" []],
--             N "A. J. Granville"
--               [N "B. Mazur"
--                  [N "Andrew Wiles" []]]]
arbolDeErdos :: [(String, String)] -> String -> Arbol String
arbolDeErdos xs a =
  N a [arbolDeErdos noColaboradores n | n <- colaboradores]
  where
    colaboradores   = [filtra a (x,y) | (x,y) <- xs, x == a || y == a]
    filtra a (x,y) | a == x    = y
                   | otherwise = x
    noColaboradores = [(x,y) | (x,y) <- xs, x /= a, y /= a]

-- (nivel n a) es la lista de los elementos del árbol a en el nivel
-- n. Por ejemplo,      
--    nivel 0 (N 3 [N 5 [N 6 []], N 7 [N 9 []]])   ==  [3]
--    nivel 1 (N 3 [N 5 [N 6 []], N 7 [N 9 []]])   ==  [5,7]
--    nivel 2 (N 3 [N 5 [N 6 []], N 7 [N 9 []]])   ==  [6,9]
nivel :: Int -> Arbol a -> [a]
nivel 0 (N a xs) = [a]
nivel n (N a xs) = concatMap (nivel (n-1)) xs

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

numeroDeErdos2 :: [(String, String)] -> Int -> [String]
numeroDeErdos2 = auxC ["Paul Erdos"] 
  where
    auxC v xs 0 = v
    auxC v xs x = auxC  (n v) (m v xs) (x-1)
      where n v =     [a | (a,b) <- xs, elem b v] ++
                      [b | (a,b) <- xs, elem a v]
            m ys xs = [(a,b) | (a,b) <- xs
                             , notElem a ys && notElem b ys]

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

numeroDeErdos3 :: [(String, String)] -> Int -> [String]
numeroDeErdos3 ps n = (sucCoautores "Paul Erdos" ps) !! n

-- (sucCoautores a ps) es la sucesión de coautores de a en ps ordenados
-- por diatancia. Por ejemplo, 
--    λ> take 3 (sucCoautores "Paul Erdos" coautores)
--    [["Paul Erdos"],
--     ["Ernst Straus","Pascual Jordan","D. Kleitman","J. Conway",
--      "A. J. Granville"],
--     ["Albert Einstein","John von Newmann","S. Glashow","P. Doyle",
--      "B. Mazur"]]
--    λ> sucCoautores "Albert Einstein" coautores
--    [["Albert Einstein"],
--     ["Ernst Straus","Otto Stern","Wolfgang Pauli"],
--     ["Paul Erdos"],
--     ["Pascual Jordan","D. Kleitman","J. Conway", "A. J. Granville"],
--     ["John von Newmann","S. Glashow","P. Doyle","B. Mazur"],
--     ["David Hilbert","M. Gell-Mann","Andrew Wiles"],
--     ["David Pines","Richar Feynman"],
--     ["D. Bohm","A. Bohr"],
--     ["L. De Broglie"]]
sucCoautores :: String -> [(String, String)] -> [[String]]
sucCoautores a ps =
  takeWhile (not . null) (map fst (iterate sig ([a], as \\ [a])))
  where as = elementos ps
        sig (xs,ys) = (zs,ys \\ zs)
          where zs = [y | y <- ys
                        , or [elem (x,y) ps || elem (y,x) ps | x <- xs]]

-- (elementos ps) es la lista de los elementos de los pares ps. Por
-- ejemplo,
--    elementos [(1,3),(3,2),(1,5)]  ==  [1,3,2,5]
elementos :: Eq a => [(a, a)] -> [a]
elementos = nub . (concatMap (\(x,y) -> [x,y]))

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

data Arbol a = N a [Arbol a]

deriving Show

coautores :: [(String,String)]

coautores =

[("Paul Erdos","Ernst Straus"),("Paul Erdos","Pascual Jordan"),

("Paul Erdos","D. Kleitman"),("Albert Einstein","Ernst Straus"),

("John von Newmann","David Hilbert"),("S. Glashow","D. Kleitman"),

("John von Newmann","Pascual Jordan"), ("David Pines","D. Bohm"),

("Albert Einstein","Otto Stern"),("S. Glashow", "M. Gell-Mann"),

("Richar Feynman","M. Gell-Mann"),("M. Gell-Mann","David Pines"),

("David Pines","A. Bohr"),("Wolfgang Pauli","Albert Einstein"),

("D. Bohm","L. De Broglie"), ("Paul Erdos","J. Conway"),

("J. Conway", "P. Doyle"),("Paul Erdos","A. J. Granville"),

("A. J. Granville","B. Mazur"),("B. Mazur","Andrew Wiles")]

-- 1ª solución

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

numeroDeErdos :: [(String, String)] -> Int -> [String]

numeroDeErdos xs n = nivel n (arbolDeErdos xs "Paul Erdos")

-- (arbolDeErdos xs a) es el árbol de coautores de a según la lista de

-- coautores xs. Por ejemplo,

-- λ> arbolDeErdos coautores "Paul Erdos"

-- N "Paul Erdos"

-- [N "Ernst Straus"

-- [N "Albert Einstein"

-- [N "Wolfgang Pauli" [],

-- N "Otto Stern" []]],

-- N "Pascual Jordan"

-- [N "John von Newmann"

-- [N "David Hilbert" []]],

-- N "D. Kleitman"

-- [N "S. Glashow"

-- [N "M. Gell-Mann"

-- [N "Richar Feynman" [],

-- N "David Pines"

-- [N "A. Bohr" [],

-- N "D. Bohm"

-- [N "L. De Broglie" []]]]]],

-- N "J. Conway"

-- [N "P. Doyle" []],

-- N "A. J. Granville"

-- [N "B. Mazur"

-- [N "Andrew Wiles" []]]]

arbolDeErdos :: [(String, String)] -> String -> Arbol String

arbolDeErdos xs a =

N a [arbolDeErdos noColaboradores n | n <- colaboradores]

where

colaboradores = [filtra a (x,y) | (x,y) <- xs, x == a || y == a]

filtra a (x,y) | a == x = y

| otherwise = x

noColaboradores = [(x,y) | (x,y) <- xs, x /= a, y /= a]

-- (nivel n a) es la lista de los elementos del árbol a en el nivel

-- n. Por ejemplo,

-- nivel 0 (N 3 [N 5 [N 6 []], N 7 [N 9 []]]) == [3]

-- nivel 1 (N 3 [N 5 [N 6 []], N 7 [N 9 []]]) == [5,7]

-- nivel 2 (N 3 [N 5 [N 6 []], N 7 [N 9 []]]) == [6,9]

nivel :: Int -> Arbol a -> [a]

nivel 0 (N a xs) = [a]

nivel n (N a xs) = concatMap (nivel (n-1)) xs

-- 2ª solución

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

numeroDeErdos2 :: [(String, String)] -> Int -> [String]

numeroDeErdos2 = auxC ["Paul Erdos"]

where

auxC v xs 0 = v

auxC v xs x = auxC (n v) (m v xs) (x-1)

where n v = [a | (a,b) <- xs, elem b v] ++

[b | (a,b) <- xs, elem a v]

m ys xs = [(a,b) | (a,b) <- xs

, notElem a ys && notElem b ys]

-- 3ª solución

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

numeroDeErdos3 :: [(String, String)] -> Int -> [String]

numeroDeErdos3 ps n = (sucCoautores "Paul Erdos" ps) !! n

-- (sucCoautores a ps) es la sucesión de coautores de a en ps ordenados

-- por diatancia. Por ejemplo,

-- λ> take 3 (sucCoautores "Paul Erdos" coautores)

-- [["Paul Erdos"],

-- ["Ernst Straus","Pascual Jordan","D. Kleitman","J. Conway",

-- "A. J. Granville"],

-- ["Albert Einstein","John von Newmann","S. Glashow","P. Doyle",

-- "B. Mazur"]]

-- λ> sucCoautores "Albert Einstein" coautores

-- [["Albert Einstein"],

-- ["Ernst Straus","Otto Stern","Wolfgang Pauli"],

-- ["Paul Erdos"],

-- ["Pascual Jordan","D. Kleitman","J. Conway", "A. J. Granville"],

-- ["John von Newmann","S. Glashow","P. Doyle","B. Mazur"],

-- ["David Hilbert","M. Gell-Mann","Andrew Wiles"],

-- ["David Pines","Richar Feynman"],

-- ["D. Bohm","A. Bohr"],

-- ["L. De Broglie"]]

sucCoautores :: String -> [(String, String)] -> [[String]]

sucCoautores a ps =

takeWhile (not . null) (map fst (iterate sig ([a], as \\ [a])))

where as = elementos ps

sig (xs,ys) = (zs,ys \\ zs)

where zs = [y | y <- ys

, or [elem (x,y) ps || elem (y,x) ps | x <- xs]]

-- (elementos ps) es la lista de los elementos de los pares ps. Por

-- ejemplo,

-- elementos [(1,3),(3,2),(1,5)] == [1,3,2,5]

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

elementos = nub . (concatMap (\(x,y) -> [x,y]))

Mayor sección inicial sin repetidos

PorJosé A. Alonso 15-marzo-20161-mayo-2016

Definir la función

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

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

tal que (seccion xs) es el mayor sección inicial de xs que no contiene ningún elemento repetido. Por ejemplo:

   seccion [1,2,3,2,4,5]                      == [1,2,3] 
   seccion "caceres"                          == "ca"
   length (seccion ([1..7531] ++ [1..10^9]))  ==  7531

seccion [1,2,3,2,4,5] == [1,2,3]

seccion "caceres" == "ca"

length (seccion ([1..7531] ++ [1..10^9])) == 7531

Soluciones

import Data.List (inits, nub)

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

seccion1 :: Eq a => [a] -> [a]
seccion1 = last . filter (\ys -> nub ys == ys) . inits

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

seccion2 :: Eq a => [a] -> [a]
seccion2 xs = aux xs []
    where aux [] ys = reverse ys
          aux (x:xs) ys | x `elem` ys = reverse ys
                        | otherwise   = aux xs (x:ys)

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

--    ghci> last (seccion1 [1..10^3])
--    1000
--    (6.19 secs, 59,174,640 bytes)
--    ghci> last (seccion2 [1..10^3])
--    1000
--    (0.04 secs, 0 bytes)

import Data.List (inits, nub)

-- 1ª solución

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

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

seccion1 = last . filter (\ys -> nub ys == ys) . inits

-- 2ª solución

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

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

seccion2 xs = aux xs []

where aux [] ys = reverse ys

aux (x:xs) ys | x `elem` ys = reverse ys

| otherwise = aux xs (x:ys)

-- Comparación de eficiencia

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

-- ghci> last (seccion1 [1..10^3])

-- 1000

-- (6.19 secs, 59,174,640 bytes)

-- ghci> last (seccion2 [1..10^3])

-- 1000

-- (0.04 secs, 0 bytes)

Múltiplos con ceros y unos

PorJosé A. Alonso 23-febrero-201625-marzo-2022

Se observa que todos los primeros números naturales tienen al menos un múltiplo no nulo que está formado solamente por ceros y unos. Por ejemplo, 1×10=10, 2×5=10, 3×37=111, 4×25=100, 5×2=10, 6×185=1110; 7×143=1001; 8X125=1000; 9×12345679=111111111.

Definir la función

   multiplosCon1y0 :: Integer -> [Integer]

1	multiplosCon1y0 :: Integer -> [Integer]

tal que (multiplosCon1y0 n) es la lista de los múltiplos de n cuyos dígitos son 1 ó 0. Por ejemplo,

   take 4 (multiplosCon1y0 3)      ==  [111,1011,1101,1110]
   take 3 (multiplosCon1y0 23)     ==  [110101,1011011,1101010]
   head (multiplosCon1y0 1234658)  ==  110101101101000000110

take 4 (multiplosCon1y0 3) == [111,1011,1101,1110]

take 3 (multiplosCon1y0 23) == [110101,1011011,1101010]

head (multiplosCon1y0 1234658) == 110101101101000000110

Comprobar con QuickCheck que todo entero positivo tiene algún múltiplo cuyos dígitos son 1 ó 0.

Soluciones

import Test.QuickCheck

multiplosCon1y0 :: Integer -> [Integer] 
multiplosCon1y0 n = 
    [x | x <- numerosCon1y0, 
         x `rem` n == 0] 

-- numerosCon1y0 es la lista de los números cuyos dígitos son 1 ó 0. Por
-- ejemplo,  
--    ghci> take 15 numerosCon1y0
--    [1,10,11,100,101,110,111,1000,1001,1010,1011,1100,1101,1110,1111]
numerosCon1y0 :: [Integer]
numerosCon1y0 = 1 : concat [[10*x,10*x+1] | x <- numerosCon1y0]

-- La propiedad es
prop_existe_multiplosCon1y0 :: Integer -> Property
prop_existe_multiplosCon1y0 n = 
    n > 0 ==> multiplosCon1y0 n /= []

-- La comprobación es
--    ghci> quickCheck prop_existe_multiplosCon1y0
--    +++ OK, passed 100 tests.

import Test.QuickCheck

multiplosCon1y0 :: Integer -> [Integer]

multiplosCon1y0 n =

[x | x <- numerosCon1y0,

x `rem` n == 0]

-- numerosCon1y0 es la lista de los números cuyos dígitos son 1 ó 0. Por

-- ejemplo,

-- ghci> take 15 numerosCon1y0

-- [1,10,11,100,101,110,111,1000,1001,1010,1011,1100,1101,1110,1111]

numerosCon1y0 :: [Integer]

numerosCon1y0 = 1 : concat [[10*x,10*x+1] | x <- numerosCon1y0]

-- La propiedad es

prop_existe_multiplosCon1y0 :: Integer -> Property

prop_existe_multiplosCon1y0 n =

n > 0 ==> multiplosCon1y0 n /= []

-- La comprobación es

-- ghci> quickCheck prop_existe_multiplosCon1y0

-- +++ OK, passed 100 tests.

Antiimágenes en una función creciente

PorJosé A. Alonso 20-enero-201626-marzo-2022

Definir la función

   antiimagen :: (Int -> Int) -> Int -> Maybe Int

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

tal que (antiimagen f y) es justo el x tal que f(x) = y, si y pertenece a la imagen de la función creciente f, o nada, en caso contrario. Por ejemplo,

   antiimagen (^2) 25  ==  Just 5
   antiimagen (^3) 25  ==  Nothing

1 2	antiimagen (^2) 25 == Just 5 antiimagen (^3) 25 == Nothing

Nota. Se supone que f está definida sobre los números naturales.

Soluciones

-- 1ª definición
-- =============

antiimagen1 :: (Int -> Int) -> Int -> Maybe Int
antiimagen1 f y 
    | estaEnImagen f y = Just x
    | otherwise        = Nothing
    where x = head [x | x <- [0..], f x == y]

-- (estaEnImagen f y) se verifica si pertenece a la imagen de f. Por
-- ejemplo, 
--    estaEnImagen (^2) 25 == True
--    estaEnImagen (^2) 30 == False
estaEnImagen :: (Int -> Int) -> Int -> Bool
estaEnImagen f y = elem y (takeWhile (<=y) (imagen f)) 

-- (imagen f) es la imagen de f. Por ejemplo,
--    take 10 (imagen (^2))  ==  [0,1,4,9,16,25,36,49,64,81]
--    take 10 (imagen (*3))  ==  [0,3,6,9,12,15,18,21,24,27]
imagen :: (Int -> Int) -> [Int]
imagen f = map f [0..]

-- 2ª definición (con lookup y maxBound)
-- =====================================

antiimagen2 :: (Int -> Int) -> Int -> Maybe Int
antiimagen2 f y =
    lookup y (takeWhile (<= (y,maxBound)) [(f x, x) | x <- [0..]])

-- 1ª definición

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

antiimagen1 :: (Int -> Int) -> Int -> Maybe Int

antiimagen1 f y

| estaEnImagen f y = Just x

| otherwise = Nothing

where x = head [x | x <- [0..], f x == y]

-- (estaEnImagen f y) se verifica si pertenece a la imagen de f. Por

-- ejemplo,

-- estaEnImagen (^2) 25 == True

-- estaEnImagen (^2) 30 == False

estaEnImagen :: (Int -> Int) -> Int -> Bool

estaEnImagen f y = elem y (takeWhile (<=y) (imagen f))

-- (imagen f) es la imagen de f. Por ejemplo,

-- take 10 (imagen (^2)) == [0,1,4,9,16,25,36,49,64,81]

-- take 10 (imagen (*3)) == [0,3,6,9,12,15,18,21,24,27]

imagen :: (Int -> Int) -> [Int]

imagen f = map f [0..]

-- 2ª definición (con lookup y maxBound)

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

antiimagen2 :: (Int -> Int) -> Int -> Maybe Int

antiimagen2 f y =

lookup y (takeWhile (<= (y,maxBound)) [(f x, x) | x <- [0..]])

Relleno de matrices

PorJosé A. Alonso 19-enero-201626-enero-2016

Dada una matriz cuyos elementos son 0 ó 1, su relleno es la matriz obtenida haciendo iguales a 1 los elementos de las filas y de las columna que contienen algún uno. Por ejemplo, el relleno de la matriz de la izquierda es la de la derecha:

   0 0 0 0 0    1 0 0 1 0
   0 0 0 0 0    1 0 0 1 0
   0 0 0 1 0    1 1 1 1 1
   1 0 0 0 0    1 1 1 1 1
   0 0 0 0 0    1 0 0 1 0

0 0 0 0 0 1 0 0 1 0

0 0 0 1 0 1 1 1 1 1

1 0 0 0 0 1 1 1 1 1

0 0 0 0 0 1 0 0 1 0

Las matrices se pueden representar mediante tablas cuyos índices son pares de enteros

   type Matriz = Array (Int,Int) Int

1	type Matriz = Array (Int,Int) Int

por ejemplo, la matriz de la izquierda de la figura anterior se define por

   ej :: Matriz                  
   ej = listArray ((1,1),(5,5)) [0, 0, 0, 0, 0,
                                 0, 0, 0, 0, 0,
                                 0, 0, 0, 1, 0,
                                 1, 0, 0, 0, 0,
                                 0, 0, 0, 0, 0]

ej :: Matriz

ej = listArray ((1,1),(5,5)) [0, 0, 0, 0, 0,

0, 0, 0, 0, 0,

0, 0, 0, 1, 0,

1, 0, 0, 0, 0,

0, 0, 0, 0, 0]

Definir la función

   relleno :: Matriz -> Matriz

1	relleno :: Matriz -> Matriz

tal que (relleno p) es el relleno de la matriz p. Por ejemplo,

   λ> elems (relleno ej)
   [1,0,0,1,0,
    1,0,0,1,0,
    1,1,1,1,1,
    1,1,1,1,1,
    1,0,0,1,0]

λ> elems (relleno ej)

[1,0,0,1,0,

1,0,0,1,0,

1,1,1,1,1,

1,0,0,1,0]

Soluciones

import Data.Array

type Matriz = Array (Int,Int) Int

ej :: Matriz                  
ej = listArray ((1,1),(5,5)) [0, 0, 0, 0, 0,
                              0, 0, 0, 0, 0,
                              0, 0, 0, 1, 0,
                              1, 0, 0, 0, 0,
                              0, 0, 0, 0, 0]

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

relleno1 :: Matriz -> Matriz
relleno1 p = 
    array ((1,1),(m,n)) [((i,j),f i j) | i <- [1..m], j <- [1..n]]
    where (_,(m,n)) = bounds p
          f i j | 1 `elem` [p!(i,k) | k <- [1..n]] = 1
                | 1 `elem` [p!(k,j) | k <- [1..m]] = 1
                | otherwise                        = 0

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

relleno2 :: Matriz -> Matriz
relleno2 p = 
    array ((1,1),(m,n)) [((i,j),f i j) | i <- [1..m], j <- [1..n]]
    where (_,(m,n)) = bounds p
          filas     = filasConUno p
          columnas  = columnasConUno p
          f i j | i `elem` filas    = 1
                | j `elem` columnas = 1
                | otherwise         = 0

-- (filasConUno p) es la lista de las filas de p que tienen algún
-- uno. Por ejemplo,
--    filasConUno ej  ==  [3,4]
filasConUno :: Matriz -> [Int]
filasConUno p = [i | i <- [1..m], filaConUno p i]
    where (_,(m,n)) = bounds p

-- (filaConUno p i) se verifica si p tiene algún uno en la fila i. Por
-- ejemplo, 
--    filaConUno ej 3  ==  True
--    filaConUno ej 2  ==  False
filaConUno :: Matriz -> Int -> Bool
filaConUno p i = any (==1) [p!(i,j) | j <- [1..n]]
    where (_,(_,n)) = bounds p

-- (columnasConUno p) es la lista de las columnas de p que tienen algún
-- uno. Por ejemplo,
--    columnasConUno ej  ==  [1,4]
columnasConUno :: Matriz -> [Int]
columnasConUno p = [j | j <- [1..n], columnaConUno p j]
    where (_,(m,n)) = bounds p

-- (columnaConUno p i) se verifica si p tiene algún uno en la columna i. Por
-- ejemplo, 
--    columnaConUno ej 1  ==  True
--    columnaConUno ej 2  ==  False
columnaConUno :: Matriz -> Int -> Bool
columnaConUno p j = any (==1) [p!(i,j) | i <- [1..m]]
    where (_,(m,_)) = bounds p

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

relleno3 :: Matriz -> Matriz
relleno3 p = p // ([((i,j),1) | i <- filas,  j <- [1..n]] ++ 
                   [((i,j),1) | i <- [1..m], j <- columnas])
  where (_,(m,n)) = bounds p
        filas     = filasConUno p
        columnas  = columnasConUno p


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

--    λ> let f i j = if i == j then 1 else 0 
--    λ> let q n = array ((1,1),(n,n)) [((i,j),f i j) | i <- [1..n], j <- [1..n]]
--    
--    λ> sum (elems (relleno1 (q 200)))
--    40000
--    (6.90 secs, 1,877,369,544 bytes)
--    
--    λ> sum (elems (relleno2 (q 200)))
--    40000
--    (0.46 secs, 57,354,168 bytes)
--    
--    λ> sum (elems (relleno3 (q 200)))
--    40000
--    (0.34 secs, 80,465,144 bytes)
--    
--    λ> sum (elems (relleno2 (q 500)))
--    250000
--    (4.33 secs, 353,117,640 bytes)
--    
--    λ> sum (elems (relleno3 (q 500)))
--    250000
--    (2.40 secs, 489,630,048 bytes)

100

101

import Data.Array

type Matriz = Array (Int,Int) Int

ej :: Matriz

ej = listArray ((1,1),(5,5)) [0, 0, 0, 0, 0,

0, 0, 0, 0, 0,

0, 0, 0, 1, 0,

1, 0, 0, 0, 0,

0, 0, 0, 0, 0]

-- 1ª solución

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

relleno1 :: Matriz -> Matriz

relleno1 p =

array ((1,1),(m,n)) [((i,j),f i j) | i <- [1..m], j <- [1..n]]

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

f i j | 1 `elem` [p!(i,k) | k <- [1..n]] = 1

| 1 `elem` [p!(k,j) | k <- [1..m]] = 1

| otherwise = 0

-- 2ª solución

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

relleno2 :: Matriz -> Matriz

relleno2 p =

array ((1,1),(m,n)) [((i,j),f i j) | i <- [1..m], j <- [1..n]]

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

filas = filasConUno p

columnas = columnasConUno p

f i j | i `elem` filas = 1

| j `elem` columnas = 1

| otherwise = 0

-- (filasConUno p) es la lista de las filas de p que tienen algún

-- uno. Por ejemplo,

-- filasConUno ej == [3,4]

filasConUno :: Matriz -> [Int]

filasConUno p = [i | i <- [1..m], filaConUno p i]

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

-- (filaConUno p i) se verifica si p tiene algún uno en la fila i. Por

-- ejemplo,

-- filaConUno ej 3 == True

-- filaConUno ej 2 == False

filaConUno :: Matriz -> Int -> Bool

filaConUno p i = any (==1) [p!(i,j) | j <- [1..n]]

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

-- (columnasConUno p) es la lista de las columnas de p que tienen algún

-- uno. Por ejemplo,

-- columnasConUno ej == [1,4]

columnasConUno :: Matriz -> [Int]

columnasConUno p = [j | j <- [1..n], columnaConUno p j]

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

-- (columnaConUno p i) se verifica si p tiene algún uno en la columna i. Por

-- ejemplo,

-- columnaConUno ej 1 == True

-- columnaConUno ej 2 == False

columnaConUno :: Matriz -> Int -> Bool

columnaConUno p j = any (==1) [p!(i,j) | i <- [1..m]]

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

-- 3ª solución

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

relleno3 :: Matriz -> Matriz

relleno3 p = p // ([((i,j),1) | i <- filas, j <- [1..n]] ++

[((i,j),1) | i <- [1..m], j <- columnas])

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

filas = filasConUno p

columnas = columnasConUno p

-- Comparación de eficiencia

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

-- λ> let f i j = if i == j then 1 else 0

-- λ> let q n = array ((1,1),(n,n)) [((i,j),f i j) | i <- [1..n], j <- [1..n]]

-- λ> sum (elems (relleno1 (q 200)))

-- 40000

-- (6.90 secs, 1,877,369,544 bytes)

-- λ> sum (elems (relleno2 (q 200)))

-- 40000

-- (0.46 secs, 57,354,168 bytes)

-- λ> sum (elems (relleno3 (q 200)))

-- 40000

-- (0.34 secs, 80,465,144 bytes)

-- λ> sum (elems (relleno2 (q 500)))

-- 250000

-- (4.33 secs, 353,117,640 bytes)

-- λ> sum (elems (relleno3 (q 500)))

-- 250000

-- (2.40 secs, 489,630,048 bytes)

Referencias

Basado en Matrix Fill-In del blog Programming Praxis.

Elementos óptimos

PorJosé A. Alonso 31-diciembre-20157-enero-2016

Definir la función

   optimos :: Eq b => (b -> b -> Bool) -> (a -> b) -> [a] -> [a]

1	optimos :: Eq b => (b -> b -> Bool) -> (a -> b) -> [a] -> [a]

tal que (optimos r f xs) es la lista de los elementos de xs donde la función f alcanza sus valores óptimos respecto de la relación r. Por ejemplo,

   optimos (<) length ["ab","c","de","f"]  ==  ["c","f"]
   optimos (>) length ["ab","c","de","f"]  ==  ["ab","de"]

1 2	optimos (<) length ["ab","c","de","f"] == ["c","f"] optimos (>) length ["ab","c","de","f"] == ["ab","de"]

Soluciones

-- 1ª definición
-- =============

optimos1 :: Eq a => (b -> b -> Bool) -> (a -> b) -> [a] -> [a]
optimos1 r f xs = 
    [x | x <- xs, null [y | y <- xs, x /= y, r (f y) (f x)]]

-- 2ª definición
-- =============

optimos2 :: Eq b => (b -> b -> Bool) -> (a -> b) -> [a] -> [a]
optimos2 r f xs = [x | x <- xs, f x `elem` ms]
    where ms = maximales r (map f xs) 

-- (maximales r xs) es la lista de los elementos de xs para los que no
-- hay ningún otro elemento de xs mayor según la relación r. Por
-- ejemplo, 
--    maximales (>) [2,3,4,6]                     ==  [6]
--    maximales (<) [2,3,4,6]                     ==  [2]
--    maximales (\x y -> mod x y == 0) [2,3,4,6]  ==  [4,6]
--    maximales (\x y -> mod y x == 0) [2,3,4,6]  ==  [2,3]
maximales :: Eq a => (a -> a -> Bool) -> [a] -> [a]
maximales r xs = [x | x <- xs, null [y | y <- xs, y /= x, r y x]]

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

--    λ> length $ optimos1 (>) length [replicate n 'a' | n <- [1..1000]]
--    1
--    (16.74 secs, 153,957,400 bytes)
--    λ> length $ optimos2 (>) length [replicate n 'a' | n <- [1..1000]]
--    1
--    (0.64 secs, 85,520,896 bytes)

-- 1ª definición

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

optimos1 :: Eq a => (b -> b -> Bool) -> (a -> b) -> [a] -> [a]

optimos1 r f xs =

[x | x <- xs, null [y | y <- xs, x /= y, r (f y) (f x)]]

-- 2ª definición

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

optimos2 :: Eq b => (b -> b -> Bool) -> (a -> b) -> [a] -> [a]

optimos2 r f xs = [x | x <- xs, f x `elem` ms]

where ms = maximales r (map f xs)

-- (maximales r xs) es la lista de los elementos de xs para los que no

-- hay ningún otro elemento de xs mayor según la relación r. Por

-- ejemplo,

-- maximales (>) [2,3,4,6] == [6]

-- maximales (<) [2,3,4,6] == [2]

-- maximales (\x y -> mod x y == 0) [2,3,4,6] == [4,6]

-- maximales (\x y -> mod y x == 0) [2,3,4,6] == [2,3]

maximales :: Eq a => (a -> a -> Bool) -> [a] -> [a]

maximales r xs = [x | x <- xs, null [y | y <- xs, y /= x, r y x]]

-- Comparación de eficiencia

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

-- λ> length $ optimos1 (>) length [replicate n 'a' | n <- [1..1000]]

-- 1

-- (16.74 secs, 153,957,400 bytes)

-- λ> length $ optimos2 (>) length [replicate n 'a' | n <- [1..1000]]

-- 1

-- (0.64 secs, 85,520,896 bytes)

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Referencia

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Referencias

Soluciones

Entradas recientes

Buscar

Correo electrónico