Medio – Página 5 – Exercitium

Entre dos conjuntos

PorJosé A. Alonso 12-diciembre-201817-enero-2019

Se dice que un x número se encuentra entre dos conjuntos xs e ys si x es divisible por todos los elementos de xs y todos los elementos de zs son divisibles por x. Por ejemplo, 12 se encuentra entre los conjuntos {2, 6} y {24, 36}.

Definir la función

   entreDosConjuntos :: [Int] -> [Int] -> [Int]

1	entreDosConjuntos :: [Int] -> [Int] -> [Int]

tal que (entreDosConjuntos xs ys) es la lista de elementos entre xs e ys (se supone que xs e ys son listas no vacías de números enteros positivos). Por ejemplo,

   entreDosConjuntos [2,6] [24,36]     ==  [6,12]
   entreDosConjuntos [2,4] [32,16,96]  ==  [4,8,16]

1 2	entreDosConjuntos [2,6] [24,36] == [6,12] entreDosConjuntos [2,4] [32,16,96] == [4,8,16]

Otros ejemplos

   λ> (xs,a) = ([1..15],product xs) 
   λ> length (entreDosConjuntos5 xs [a,2*a..10*a])
   270
   λ> (xs,a) = ([1..16],product xs) 
   λ> length (entreDosConjuntos5 xs [a,2*a..10*a])
   360

λ> (xs,a) = ([1..15],product xs)

λ> length (entreDosConjuntos5 xs [a,2*a..10*a])

270

λ> (xs,a) = ([1..16],product xs)

λ> length (entreDosConjuntos5 xs [a,2*a..10*a])

360

Soluciones

import Test.QuickCheck 

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

entreDosConjuntos :: [Int] -> [Int] -> [Int]
entreDosConjuntos xs ys =
  [z | z <- [a..b]
     , and [z `mod` x == 0 | x <- xs]
     , and [y `mod` z == 0 | y <- ys]]
  where a = maximum xs
        b = minimum ys

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

entreDosConjuntos2 :: [Int] -> [Int] -> [Int]
entreDosConjuntos2 xs ys =
  [z | z <- [a..b]
     , all (`divideA` z) xs
     , all (z `divideA`) ys]
  where a = mcmL xs
        b = mcdL ys

--    mcmL [2,3,18]  ==  18
--    mcmL [2,3,15]  ==  30
mcdL :: [Int] -> Int
mcdL [x]    = x
mcdL (x:xs) = gcd x (mcdL xs)

--    mcmL [12,30,18]  ==  6
--    mcmL [12,30,14]  ==  2
mcmL :: [Int] -> Int
mcmL [x]    = x
mcmL (x:xs) = lcm x (mcmL xs)

divideA :: Int -> Int -> Bool
divideA x y = y `mod` x == 0

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

entreDosConjuntos3 :: [Int] -> [Int] -> [Int]
entreDosConjuntos3 xs ys =
  [z | z <- [a..b]
     , all (`divideA` z) xs
     , all (z `divideA`) ys]
  where a = mcmL2 xs
        b = mcdL2 ys

-- Definición equivalente
mcdL2 :: [Int] -> Int
mcdL2 = foldl1 gcd

-- Definición equivalente
mcmL2 :: [Int] -> Int
mcmL2 = foldl1 lcm

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

entreDosConjuntos4 :: [Int] -> [Int] -> [Int]
entreDosConjuntos4 xs ys =
  [z | z <- [a,a+a..b]
     , z `divideA` b] 
  where a = mcmL2 xs
        b = mcdL2 ys

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

entreDosConjuntos5 :: [Int] -> [Int] -> [Int]
entreDosConjuntos5 xs ys =
  filter (`divideA` b) [a,a+a..b]
  where a = mcmL2 xs
        b = mcdL2 ys

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

-- Para comprobar la equivalencia se define el tipo de listas no vacías
-- de números enteros positivos:
newtype ListaNoVaciaDePositivos = L [Int]
  deriving Show

-- genListaNoVaciaDePositivos es un generador de listas no vacióas de
-- enteros positivos. Por ejemplo,
--    λ> sample genListaNoVaciaDePositivos
--    L [1]
--    L [1,2,2]
--    L [4,3,4]
--    L [1,6,5,2,4]
--    L [2,8]
--    L [11]
--    L [13,2,3]
--    L [7,3,9,15,11,12,13,3,9,6,13,3]
--    L [16,2,11,10,6,5,16,4,1,15,9,11,8,15,2,15,7]
--    L [5,4,9,13,5,6,7]
--    L [7,4,6,12,2,11,6,14,14,13,14,11,6,2,18,8,16,2,13,9]
genListaNoVaciaDePositivos :: Gen ListaNoVaciaDePositivos
genListaNoVaciaDePositivos = do
  x  <- arbitrary
  xs <- arbitrary
  return (L (map ((+1) . abs) (x:xs)))

-- Generación arbitraria de listas no vacías de enteros positivos.
instance Arbitrary ListaNoVaciaDePositivos where
  arbitrary = genListaNoVaciaDePositivos

-- La propiedad es
prop_entreDosConjuntos_equiv ::
     ListaNoVaciaDePositivos
  -> ListaNoVaciaDePositivos
  -> Bool
prop_entreDosConjuntos_equiv (L xs) (L ys) =
  entreDosConjuntos xs ys == entreDosConjuntos2 xs ys &&
  entreDosConjuntos xs ys == entreDosConjuntos3 xs ys &&
  entreDosConjuntos xs ys == entreDosConjuntos4 xs ys &&
  entreDosConjuntos xs ys == entreDosConjuntos5 xs ys 

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

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

--    λ> (xs,a) = ([1..10],product xs) 
--    λ> length (entreDosConjuntos xs [a,2*a..10*a])
--    36
--    (5.08 secs, 4,035,689,200 bytes)
--    λ> length (entreDosConjuntos2 xs [a,2*a..10*a])
--    36
--    (3.75 secs, 2,471,534,072 bytes)
--    λ> length (entreDosConjuntos3 xs [a,2*a..10*a])
--    36
--    (3.73 secs, 2,471,528,664 bytes)
--    λ> length (entreDosConjuntos4 xs [a,2*a..10*a])
--    36
--    (0.01 secs, 442,152 bytes)
--    λ> length (entreDosConjuntos5 xs [a,2*a..10*a])
--    36
--    (0.00 secs, 374,824 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

import Test.QuickCheck

-- 1ª solución

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

entreDosConjuntos :: [Int] -> [Int] -> [Int]

entreDosConjuntos xs ys =

[z | z <- [a..b]

, and [z `mod` x == 0 | x <- xs]

, and [y `mod` z == 0 | y <- ys]]

where a = maximum xs

b = minimum ys

-- 2ª solución

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

entreDosConjuntos2 :: [Int] -> [Int] -> [Int]

entreDosConjuntos2 xs ys =

[z | z <- [a..b]

, all (`divideA` z) xs

, all (z `divideA`) ys]

where a = mcmL xs

b = mcdL ys

-- mcmL [2,3,18] == 18

-- mcmL [2,3,15] == 30

mcdL :: [Int] -> Int

mcdL [x] = x

mcdL (x:xs) = gcd x (mcdL xs)

-- mcmL [12,30,18] == 6

-- mcmL [12,30,14] == 2

mcmL :: [Int] -> Int

mcmL [x] = x

mcmL (x:xs) = lcm x (mcmL xs)

divideA :: Int -> Int -> Bool

divideA x y = y `mod` x == 0

-- 3ª solución

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

entreDosConjuntos3 :: [Int] -> [Int] -> [Int]

entreDosConjuntos3 xs ys =

[z | z <- [a..b]

, all (`divideA` z) xs

, all (z `divideA`) ys]

where a = mcmL2 xs

b = mcdL2 ys

-- Definición equivalente

mcdL2 :: [Int] -> Int

mcdL2 = foldl1 gcd

-- Definición equivalente

mcmL2 :: [Int] -> Int

mcmL2 = foldl1 lcm

-- 4ª solución

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

entreDosConjuntos4 :: [Int] -> [Int] -> [Int]

entreDosConjuntos4 xs ys =

[z | z <- [a,a+a..b]

, z `divideA` b]

where a = mcmL2 xs

b = mcdL2 ys

-- 5ª solución

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

entreDosConjuntos5 :: [Int] -> [Int] -> [Int]

entreDosConjuntos5 xs ys =

filter (`divideA` b) [a,a+a..b]

where a = mcmL2 xs

b = mcdL2 ys

-- Equivalencia

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

-- Para comprobar la equivalencia se define el tipo de listas no vacías

-- de números enteros positivos:

newtype ListaNoVaciaDePositivos = L [Int]

deriving Show

-- genListaNoVaciaDePositivos es un generador de listas no vacióas de

-- enteros positivos. Por ejemplo,

-- λ> sample genListaNoVaciaDePositivos

-- L [1]

-- L [1,2,2]

-- L [4,3,4]

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

-- L [2,8]

-- L [11]

-- L [13,2,3]

-- L [7,3,9,15,11,12,13,3,9,6,13,3]

-- L [16,2,11,10,6,5,16,4,1,15,9,11,8,15,2,15,7]

-- L [5,4,9,13,5,6,7]

-- L [7,4,6,12,2,11,6,14,14,13,14,11,6,2,18,8,16,2,13,9]

genListaNoVaciaDePositivos :: Gen ListaNoVaciaDePositivos

genListaNoVaciaDePositivos = do

x <- arbitrary

xs <- arbitrary

return (L (map ((+1) . abs) (x:xs)))

-- Generación arbitraria de listas no vacías de enteros positivos.

instance Arbitrary ListaNoVaciaDePositivos where

arbitrary = genListaNoVaciaDePositivos

-- La propiedad es

prop_entreDosConjuntos_equiv ::

ListaNoVaciaDePositivos

-> ListaNoVaciaDePositivos

-> Bool

prop_entreDosConjuntos_equiv (L xs) (L ys) =

entreDosConjuntos xs ys == entreDosConjuntos2 xs ys &&

entreDosConjuntos xs ys == entreDosConjuntos3 xs ys &&

entreDosConjuntos xs ys == entreDosConjuntos4 xs ys &&

entreDosConjuntos xs ys == entreDosConjuntos5 xs ys

-- La comprobación es

-- λ> quickCheck prop_entreDosConjuntos_equiv

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- λ> (xs,a) = ([1..10],product xs)

-- λ> length (entreDosConjuntos xs [a,2*a..10*a])

-- 36

-- (5.08 secs, 4,035,689,200 bytes)

-- λ> length (entreDosConjuntos2 xs [a,2*a..10*a])

-- 36

-- (3.75 secs, 2,471,534,072 bytes)

-- λ> length (entreDosConjuntos3 xs [a,2*a..10*a])

-- 36

-- (3.73 secs, 2,471,528,664 bytes)

-- λ> length (entreDosConjuntos4 xs [a,2*a..10*a])

-- 36

-- (0.01 secs, 442,152 bytes)

-- λ> length (entreDosConjuntos5 xs [a,2*a..10*a])

-- 36

-- (0.00 secs, 374,824 bytes)

Referencia

Este ejercicio está basado en el problema Between two sets de HackerRank.

Pensamiento

Las razones no se transmiten, se engendran, por cooperación, en el diálogo.

Antonio Machado

Árbol de computación de Fibonacci

PorJosé A. Alonso 11-diciembre-201817-enero-2019

La sucesión de Fibonacci es

   0,1,1,2,3,5,8,13,21,34,55,89,144,233,377,610,987,1597,2584,...

1	0,1,1,2,3,5,8,13,21,34,55,89,144,233,377,610,987,1597,2584,...

cuyos dos primeros términos son 0 y 1 y los restantentes se obtienen sumando los dos anteriores.

El árbol de computación de su 5º término es

                 5
                / \
               /   \
              /     \
             /       \
            /         \
           3           2  
          / \         / \ 
         /   \       1   1
        2     1     / \   
       / \   / \   1   0  
      1   1 1   0
     / \ 
    1   0

/ \

3 2

/ \ / \

/ \ 1 1

2 1 / \

/ \ / \ 1 0

1 1 1 0

/ \

1 0

que, usando los árboles definidos por

   data Arbol = H Int
              | N Int Arbol Arbol
     deriving (Eq, Show)

data Arbol = H Int

| N Int Arbol Arbol

deriving (Eq, Show)

se puede representar por

   N 5              
     (N 3           
        (N 2        
           (N 1 (H 1) (H 0))
           (H 1))   
        (N 1 (H 1) (H 0)))  
     (N 2           
        (N 1 (H 1) (H 0))   
        (H 1))

N 5

(N 3

(N 2

(N 1 (H 1) (H 0))

(H 1))

(N 1 (H 1) (H 0)))

(N 2

(N 1 (H 1) (H 0))

(H 1))

Definir las funciones

   arbolFib           :: Int -> Arbol
   nElementosArbolFib :: Int -> Int

1 2	arbolFib :: Int -> Arbol nElementosArbolFib :: Int -> Int

tales que

(arbolFib n) es el árbol de computación del n-ésimo término de la sucesión de Fibonacci. Por ejemplo,

     λ> arbolFib 5
     N 5              
       (N 3           
          (N 2        
             (N 1 (H 1) (H 0))
             (H 1))   
          (N 1 (H 1) (H 0)))  
       (N 2           
          (N 1 (H 1) (H 0))   
          (H 1))
     λ> arbolFib 6
     N 8
       (N 5
          (N 3
             (N 2
                (N 1 (H 1) (H 0))
                (H 1))
             (N 1 (H 1) (H 0)))
          (N 2
             (N 1 (H 1) (H 0))
             (H 1)))
       (N 3
          (N 2
             (N 1 (H 1) (H 0)) (H 1))
          (N 1 (H 1) (H 0)))

λ> arbolFib 5

N 5

(N 3

(N 2

(N 1 (H 1) (H 0))

(H 1))

(N 1 (H 1) (H 0)))

(N 2

(N 1 (H 1) (H 0))

(H 1))

λ> arbolFib 6

N 8

(N 5

(N 3

(N 2

(N 1 (H 1) (H 0))

(H 1))

(N 1 (H 1) (H 0)))

(N 2

(N 1 (H 1) (H 0))

(H 1)))

(N 3

(N 2

(N 1 (H 1) (H 0)) (H 1))

(N 1 (H 1) (H 0)))

(nElementosArbolFib n) es el número de elementos en el árbol de computación del n-ésimo término de la sucesión de Fibonacci. Por ejemplo,

     nElementosArbolFib 5   ==  15
     nElementosArbolFib 6   ==  25
     nElementosArbolFib 30  ==  2692537

nElementosArbolFib 5 == 15

nElementosArbolFib 6 == 25

nElementosArbolFib 30 == 2692537

Soluciones

data Arbol = H Int
           | N Int Arbol Arbol
  deriving (Eq, Show)

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

arbolFib :: Int -> Arbol
arbolFib 0 = H 0
arbolFib 1 = H 1
arbolFib n = N (fib n) (arbolFib (n-1)) (arbolFib (n-2))

-- (fib n) es el n-ésimo elemento de la sucesión de Fibonacci. Por
-- ejemplo,
--    fib 5  ==  5
--    fib 6  ==  8
fib :: Int -> Int
fib 0 = 0
fib 1 = 1
fib n = fib (n-1) + fib (n-2)

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

arbolFib2 :: Int -> Arbol
arbolFib2 0 = H 0
arbolFib2 1 = H 1
arbolFib2 2 = N 1 (H 1) (H 0)
arbolFib2 3 = N 2 (N 1 (H 1) (H 0)) (H 1)
arbolFib2 n = N (a1 + a2) (N a1 i1 d1) (N a2 i2 d2)
  where (N a1 i1 d1) = arbolFib2 (n-1)
        (N a2 i2 d2) = arbolFib2 (n-2)

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

arbolFib3 :: Int -> Arbol
arbolFib3 0 = H 0
arbolFib3 1 = H 1
arbolFib3 2 = N 1 (H 1) (H 0)
arbolFib3 3 = N 2 (N 1 (H 1) (H 0)) (H 1)
arbolFib3 n = N (a + b) i d
  where i@(N a _ _) = arbolFib3 (n-1)
        d@(N b _ _) = arbolFib3 (n-2)

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

nElementosArbolFib :: Int -> Int
nElementosArbolFib = length . elementos . arbolFib3

-- (elementos a) es la lista de elementos del árbol a. Por ejemplo,
--    λ> elementos (arbolFib 5)
--    [5,3,2,1,1,0,1,1,1,0,2,1,1,0,1]
--    λ> elementos (arbolFib 6)
--    [8,5,3,2,1,1,0,1,1,1,0,2,1,1,0,1,3,2,1,1,0,1,1,1,0]
elementos :: Arbol -> [Int]
elementos (H x)     = [x]
elementos (N x i d) = x : elementos i ++ elementos d

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

nElementosArbolFib2 :: Int -> Int
nElementosArbolFib2 0 = 1
nElementosArbolFib2 1 = 1
nElementosArbolFib2 n = 1 + nElementosArbolFib2 (n-1)
                          + nElementosArbolFib2 (n-2)

data Arbol = H Int

| N Int Arbol Arbol

deriving (Eq, Show)

-- 1ª definición

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

arbolFib :: Int -> Arbol

arbolFib 0 = H 0

arbolFib 1 = H 1

arbolFib n = N (fib n) (arbolFib (n-1)) (arbolFib (n-2))

-- (fib n) es el n-ésimo elemento de la sucesión de Fibonacci. Por

-- ejemplo,

-- fib 5 == 5

-- fib 6 == 8

fib :: Int -> Int

fib 0 = 0

fib 1 = 1

fib n = fib (n-1) + fib (n-2)

-- 2ª definición

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

arbolFib2 :: Int -> Arbol

arbolFib2 0 = H 0

arbolFib2 1 = H 1

arbolFib2 2 = N 1 (H 1) (H 0)

arbolFib2 3 = N 2 (N 1 (H 1) (H 0)) (H 1)

arbolFib2 n = N (a1 + a2) (N a1 i1 d1) (N a2 i2 d2)

where (N a1 i1 d1) = arbolFib2 (n-1)

(N a2 i2 d2) = arbolFib2 (n-2)

-- 3ª definición

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

arbolFib3 :: Int -> Arbol

arbolFib3 0 = H 0

arbolFib3 1 = H 1

arbolFib3 2 = N 1 (H 1) (H 0)

arbolFib3 3 = N 2 (N 1 (H 1) (H 0)) (H 1)

arbolFib3 n = N (a + b) i d

where i@(N a _ _) = arbolFib3 (n-1)

d@(N b _ _) = arbolFib3 (n-2)

-- 1ª definición de nElementosArbolFib

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

nElementosArbolFib :: Int -> Int

nElementosArbolFib = length . elementos . arbolFib3

-- (elementos a) es la lista de elementos del árbol a. Por ejemplo,

-- λ> elementos (arbolFib 5)

-- [5,3,2,1,1,0,1,1,1,0,2,1,1,0,1]

-- λ> elementos (arbolFib 6)

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

elementos :: Arbol -> [Int]

elementos (H x) = [x]

elementos (N x i d) = x : elementos i ++ elementos d

-- 2ª definición de nElementosArbolFib

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

nElementosArbolFib2 :: Int -> Int

nElementosArbolFib2 0 = 1

nElementosArbolFib2 1 = 1

nElementosArbolFib2 n = 1 + nElementosArbolFib2 (n-1)

+ nElementosArbolFib2 (n-2)

Pensamiento

Toda visión requiere distancia.

Antonio Machado

Elemento del árbol binario completo según su posición

PorJosé A. Alonso 6-diciembre-201817-enero-2019

Un árbol binario completo es un árbol binario que tiene todos los nodos posibles hasta el penúltimo nivel, y donde los elementos del último nivel están colocados de izquierda a derecha sin dejar huecos entre ellos.

La numeración de los árboles binarios completos se realiza a partir de la raíz, recorriendo los niveles de izquierda a derecha. Por ejemplo,

                  1
                 /  \
                /    \
               /      \
              2        3
             / \      / \
            4   5    6   7
           / \ 
          8   9

/ \

2 3

/ \ / \

4 5 6 7

/ \

8 9

Los árboles binarios se puede representar mediante el siguiente tipo

   data Arbol = H
              | N Integer Arbol Arbol
     deriving (Show, Eq)

data Arbol = H

| N Integer Arbol Arbol

deriving (Show, Eq)

Cada posición de un elemento de un árbol es una lista de movimientos hacia la izquierda o hacia la derecha. Por ejemplo, la posición de 9 en al árbol anterior es [I,I,D].

Los tipos de los movimientos y de las posiciones se definen por

   data Movimiento = I | D deriving (Show, Eq)
   type Posicion   = [Movimiento]

1 2	data Movimiento = I \| D deriving (Show, Eq) type Posicion = [Movimiento]

Definir la función

   elementoEnPosicion :: Posicion -> Integer

1	elementoEnPosicion :: Posicion -> Integer

tal que (elementoEnPosicion ms) es el elemento en la posición ms. Por ejemplo,

   elementoEnPosicion [D,I]    ==  6
   elementoEnPosicion [D,D]    ==  7
   elementoEnPosicion [I,I,D]  ==  9
   elementoEnPosicion []       ==  1

elementoEnPosicion [D,I] == 6

elementoEnPosicion [D,D] == 7

elementoEnPosicion [I,I,D] == 9

elementoEnPosicion [] == 1

Soluciones

import Test.QuickCheck

data Arbol = H
           | N Integer Arbol Arbol
  deriving (Eq, Show)

data Movimiento = I | D deriving (Show, Eq)

type Posicion = [Movimiento]

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

elementoEnPosicion :: Posicion -> Integer
elementoEnPosicion ms =
  aux ms (arbolBinarioCompleto (2^(1 + length ms)))
  where aux []     (N x _ _) = x
        aux (I:ms) (N _ i _) = aux ms i
        aux (D:ms) (N _ _ d) = aux ms d

-- (arbolBinarioCompleto n) es el árbol binario completo con n
-- nodos. Por ejemplo, 
--    λ> arbolBinarioCompleto 4
--    N 1 (N 2 (N 4 H H) H) (N 3 H H)
--    λ> pPrint (arbolBinarioCompleto 9)
--    N 1
--      (N 2
--         (N 4
--            (N 8 H H)
--            (N 9 H H))
--         (N 5 H H))
--      (N 3
--         (N 6 H H)
--         (N 7 H H))
arbolBinarioCompleto :: Integer -> Arbol
arbolBinarioCompleto n = aux 1
  where aux i | i <= n    = N i (aux (2*i)) (aux (2*i+1))
              | otherwise = H

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

elementoEnPosicion2 :: Posicion -> Integer
elementoEnPosicion2 = aux . reverse
  where aux []     = 1
        aux (I:ms) = 2 * aux ms
        aux (D:ms) = 2 * aux ms + 1

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

-- La propiedad es
prop_elementoEnPosicion_equiv :: Positive Integer -> Bool
prop_elementoEnPosicion_equiv (Positive n) =
  elementoEnPosicion  ps == n &&
  elementoEnPosicion2 ps == n 
  where ps = posicionDeElemento n

-- tal que (posicionDeElemento n) es la posición del elemento n en el
-- árbol binario completo. Por ejemplo,
--    posicionDeElemento 6  ==  [D,I]
--    posicionDeElemento 7  ==  [D,D]
--    posicionDeElemento 9  ==  [I,I,D]
--    posicionDeElemento 1  ==  []
posicionDeElemento :: Integer -> Posicion
posicionDeElemento n =
  [f x | x <- tail (reverse (binario n))]
  where f 0 = I
        f 1 = D

-- (binario n) es la lista de los dígitos de la representación binaria
-- de n. Por ejemplo,
--    binario 11  ==  [1,1,0,1]
binario :: Integer -> [Integer]
binario n
  | n < 2     = [n]
  | otherwise = n `mod` 2 : binario (n `div` 2)

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

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

--    λ> length (show (elementoEnPosicion (replicate (3*10^5) D)))
--    90310
--    (1.96 secs, 11,518,771,016 bytes)
--    λ> length (show (elementoEnPosicion2 (replicate (3*10^5) D)))
--    90310
--    (14.32 secs, 11,508,181,176 bytes)

import Test.QuickCheck

data Arbol = H

| N Integer Arbol Arbol

deriving (Eq, Show)

data Movimiento = I | D deriving (Show, Eq)

type Posicion = [Movimiento]

-- 1ª solución

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

elementoEnPosicion :: Posicion -> Integer

elementoEnPosicion ms =

aux ms (arbolBinarioCompleto (2^(1 + length ms)))

where aux [] (N x _ _) = x

aux (I:ms) (N _ i _) = aux ms i

aux (D:ms) (N _ _ d) = aux ms d

-- (arbolBinarioCompleto n) es el árbol binario completo con n

-- nodos. Por ejemplo,

-- λ> arbolBinarioCompleto 4

-- N 1 (N 2 (N 4 H H) H) (N 3 H H)

-- λ> pPrint (arbolBinarioCompleto 9)

-- N 1

-- (N 2

-- (N 4

-- (N 8 H H)

-- (N 9 H H))

-- (N 5 H H))

-- (N 3

-- (N 6 H H)

-- (N 7 H H))

arbolBinarioCompleto :: Integer -> Arbol

arbolBinarioCompleto n = aux 1

where aux i | i <= n = N i (aux (2*i)) (aux (2*i+1))

| otherwise = H

-- 2ª solución

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

elementoEnPosicion2 :: Posicion -> Integer

elementoEnPosicion2 = aux . reverse

where aux [] = 1

aux (I:ms) = 2 * aux ms

aux (D:ms) = 2 * aux ms + 1

-- Equivalencia

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

-- La propiedad es

prop_elementoEnPosicion_equiv :: Positive Integer -> Bool

prop_elementoEnPosicion_equiv (Positive n) =

elementoEnPosicion ps == n &&

elementoEnPosicion2 ps == n

where ps = posicionDeElemento n

-- tal que (posicionDeElemento n) es la posición del elemento n en el

-- árbol binario completo. Por ejemplo,

-- posicionDeElemento 6 == [D,I]

-- posicionDeElemento 7 == [D,D]

-- posicionDeElemento 9 == [I,I,D]

-- posicionDeElemento 1 == []

posicionDeElemento :: Integer -> Posicion

posicionDeElemento n =

[f x | x <- tail (reverse (binario n))]

where f 0 = I

f 1 = D

-- (binario n) es la lista de los dígitos de la representación binaria

-- de n. Por ejemplo,

-- binario 11 == [1,1,0,1]

binario :: Integer -> [Integer]

binario n

| n < 2 = [n]

| otherwise = n `mod` 2 : binario (n `div` 2)

-- La comprobación es

-- λ> quickCheck prop_elementoEnPosicion_equiv

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- λ> length (show (elementoEnPosicion (replicate (3*10^5) D)))

-- 90310

-- (1.96 secs, 11,518,771,016 bytes)

-- λ> length (show (elementoEnPosicion2 (replicate (3*10^5) D)))

-- 90310

-- (14.32 secs, 11,508,181,176 bytes)

Pensamiento

Las más hondas palabras
del sabio nos enseñan
lo que el silbar del viento cuando sopla
o el sonar de las aguas cuando ruedan.

Antonio Machado

Posiciones en árboles binarios completos

PorJosé A. Alonso 5-diciembre-201819-enero-2019

La numeración de los árboles binarios completos se realiza a partir de la raíz, recorriendo los niveles de izquierda a derecha. Por ejemplo,

                  1
                 /  \
                /    \
               /      \
              2        3
             / \      / \
            4   5    6   7
           / \    
          8   9

/ \

2 3

/ \ / \

4 5 6 7

/ \

8 9

Los árboles binarios se puede representar mediante el siguiente tipo

   data Arbol = H
              | N Integer Arbol Arbol
     deriving (Show, Eq)

data Arbol = H

| N Integer Arbol Arbol

deriving (Show, Eq)

Cada posición de un elemento de un árbol es una lista de movimientos hacia la izquierda o hacia la derecha. Por ejemplo, la posición de 9 en al árbol anterior es [I,I,D].

Los tipos de los movimientos y de las posiciones se definen por

   data Movimiento = I | D deriving (Show, Eq)
   type Posicion   = [Movimiento]

1 2	data Movimiento = I \| D deriving (Show, Eq) type Posicion = [Movimiento]

Definir la función

   posicionDeElemento :: Integer -> Posicion

1	posicionDeElemento :: Integer -> Posicion

tal que (posicionDeElemento n) es la posición del elemento n en el árbol binario completo. Por ejemplo,

   posicionDeElemento 6  ==  [D,I]
   posicionDeElemento 7  ==  [D,D]
   posicionDeElemento 9  ==  [I,I,D]
   posicionDeElemento 1  ==  []

   length (posicionDeElemento (10^50000))  ==  166096

posicionDeElemento 6 == [D,I]

posicionDeElemento 7 == [D,D]

posicionDeElemento 9 == [I,I,D]

posicionDeElemento 1 == []

length (posicionDeElemento (10^50000)) == 166096

Soluciones

import Test.QuickCheck

data Arbol = H
           | N Integer Arbol Arbol
  deriving (Eq, Show)

data Movimiento = I | D deriving (Show, Eq)

type Posicion = [Movimiento]

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

posicionDeElemento :: Integer -> Posicion
posicionDeElemento n =
  head (posiciones n (arbolBinarioCompleto n))

-- (arbolBinarioCompleto n) es el árbol binario completo con n
-- nodos. Por ejemplo, 
--    λ> arbolBinarioCompleto 4
--    N 1 (N 2 (N 4 H H) H) (N 3 H H)
--    λ> pPrint (arbolBinarioCompleto 9)
--    N 1
--      (N 2
--         (N 4
--            (N 8 H H)
--            (N 9 H H))
--         (N 5 H H))
--      (N 3
--         (N 6 H H)
--         (N 7 H H))
arbolBinarioCompleto :: Integer -> Arbol
arbolBinarioCompleto n = aux 1
  where aux i | i <= n    = N i (aux (2*i)) (aux (2*i+1))
              | otherwise = H

-- (posiciones n a) es la lista de las posiciones del elemento n
-- en el árbol a. Por ejemplo,
--    posiciones 9 (arbolBinarioCompleto 9)  ==  [[I,I,D]]
posiciones :: Integer -> Arbol -> [Posicion]
posiciones n a = aux n a [[]]
  where aux _ H _                      = []
        aux n (N x i d) cs | x == n    = cs ++ ps
                           | otherwise = ps
          where ps = map (I:) (aux n i cs) ++
                     map (D:) (aux n d cs)

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

posicionDeElemento2 :: Integer -> Posicion
posicionDeElemento2 1 = []
posicionDeElemento2 n
  | even n    = posicionDeElemento2 (n `div` 2) ++ [I]
  | otherwise = posicionDeElemento2 (n `div` 2) ++ [D]

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

posicionDeElemento3 :: Integer -> Posicion
posicionDeElemento3 = reverse . aux
  where aux 1 = []
        aux n | even n    = I : aux (n `div` 2) 
              | otherwise = D : aux (n `div` 2) 

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

posicionDeElemento4 :: Integer -> Posicion
posicionDeElemento4 n =
  [f x | x <- tail (reverse (binario n))]
  where f 0 = I
        f 1 = D

-- (binario n) es la lista de los dígitos de la representación binaria
-- de n. Por ejemplo,
--    binario 11  ==  [1,1,0,1]
binario :: Integer -> [Integer]
binario n
  | n < 2     = [n]
  | otherwise = n `mod` 2 : binario (n `div` 2)

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

-- La propiedad es
prop_posicionDeElemento_equiv :: Positive Integer -> Bool
prop_posicionDeElemento_equiv (Positive n) =
  posicionDeElemento n == posicionDeElemento2 n &&
  posicionDeElemento n == posicionDeElemento3 n &&
  posicionDeElemento n == posicionDeElemento4 n

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

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

--    λ> posicionDeElemento (10^7)
--    [I,I,D,D,I,I,I,D,I,I,D,I,D,D,I,D,I,I,I,I,I,I,I]
--    (5.72 secs, 3,274,535,328 bytes)
--    λ> posicionDeElemento2 (10^7)
--    [I,I,D,D,I,I,I,D,I,I,D,I,D,D,I,D,I,I,I,I,I,I,I]
--    (0.01 secs, 189,560 bytes)
--    λ> posicionDeElemento3 (10^7)
--    [I,I,D,D,I,I,I,D,I,I,D,I,D,D,I,D,I,I,I,I,I,I,I]
--    (0.01 secs, 180,728 bytes)
--    λ> posicionDeElemento4 (10^7)
--    [I,I,D,D,I,I,I,D,I,I,D,I,D,D,I,D,I,I,I,I,I,I,I]
--    (0.01 secs, 184,224 bytes)
--    
--    λ> length (posicionDeElemento2 (10^4000))
--    13287
--    (2.80 secs, 7,672,011,280 bytes)
--    λ> length (posicionDeElemento3 (10^4000))
--    13287
--    (0.03 secs, 19,828,744 bytes)
--    λ> length (posicionDeElemento4 (10^4000))
--    13287
--    (0.03 secs, 18,231,536 bytes)
--    
--    λ> length (posicionDeElemento3 (10^50000))
--    166096
--    (1.34 secs, 1,832,738,136 bytes)
--    λ> length (posicionDeElemento4 (10^50000))
--    166096
--    (1.70 secs, 1,812,806,080 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 Test.QuickCheck

data Arbol = H

| N Integer Arbol Arbol

deriving (Eq, Show)

data Movimiento = I | D deriving (Show, Eq)

type Posicion = [Movimiento]

-- 1ª solución

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

posicionDeElemento :: Integer -> Posicion

posicionDeElemento n =

head (posiciones n (arbolBinarioCompleto n))

-- (arbolBinarioCompleto n) es el árbol binario completo con n

-- nodos. Por ejemplo,

-- λ> arbolBinarioCompleto 4

-- N 1 (N 2 (N 4 H H) H) (N 3 H H)

-- λ> pPrint (arbolBinarioCompleto 9)

-- N 1

-- (N 2

-- (N 4

-- (N 8 H H)

-- (N 9 H H))

-- (N 5 H H))

-- (N 3

-- (N 6 H H)

-- (N 7 H H))

arbolBinarioCompleto :: Integer -> Arbol

arbolBinarioCompleto n = aux 1

where aux i | i <= n = N i (aux (2*i)) (aux (2*i+1))

| otherwise = H

-- (posiciones n a) es la lista de las posiciones del elemento n

-- en el árbol a. Por ejemplo,

-- posiciones 9 (arbolBinarioCompleto 9) == [[I,I,D]]

posiciones :: Integer -> Arbol -> [Posicion]

posiciones n a = aux n a [[]]

where aux _ H _ = []

aux n (N x i d) cs | x == n = cs ++ ps

| otherwise = ps

where ps = map (I:) (aux n i cs) ++

map (D:) (aux n d cs)

-- 2ª solución

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

posicionDeElemento2 :: Integer -> Posicion

posicionDeElemento2 1 = []

posicionDeElemento2 n

| even n = posicionDeElemento2 (n `div` 2) ++ [I]

| otherwise = posicionDeElemento2 (n `div` 2) ++ [D]

-- 3ª solución

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

posicionDeElemento3 :: Integer -> Posicion

posicionDeElemento3 = reverse . aux

where aux 1 = []

aux n | even n = I : aux (n `div` 2)

| otherwise = D : aux (n `div` 2)

-- 4ª solución

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

posicionDeElemento4 :: Integer -> Posicion

posicionDeElemento4 n =

[f x | x <- tail (reverse (binario n))]

where f 0 = I

f 1 = D

-- (binario n) es la lista de los dígitos de la representación binaria

-- de n. Por ejemplo,

-- binario 11 == [1,1,0,1]

binario :: Integer -> [Integer]

binario n

| n < 2 = [n]

| otherwise = n `mod` 2 : binario (n `div` 2)

-- Equivalencia

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

-- La propiedad es

prop_posicionDeElemento_equiv :: Positive Integer -> Bool

prop_posicionDeElemento_equiv (Positive n) =

posicionDeElemento n == posicionDeElemento2 n &&

posicionDeElemento n == posicionDeElemento3 n &&

posicionDeElemento n == posicionDeElemento4 n

-- La comprobación es

-- λ> quickCheck prop_posicionDeElemento_equiv

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- λ> posicionDeElemento (10^7)

-- [I,I,D,D,I,I,I,D,I,I,D,I,D,D,I,D,I,I,I,I,I,I,I]

-- (5.72 secs, 3,274,535,328 bytes)

-- λ> posicionDeElemento2 (10^7)

-- [I,I,D,D,I,I,I,D,I,I,D,I,D,D,I,D,I,I,I,I,I,I,I]

-- (0.01 secs, 189,560 bytes)

-- λ> posicionDeElemento3 (10^7)

-- [I,I,D,D,I,I,I,D,I,I,D,I,D,D,I,D,I,I,I,I,I,I,I]

-- (0.01 secs, 180,728 bytes)

-- λ> posicionDeElemento4 (10^7)

-- [I,I,D,D,I,I,I,D,I,I,D,I,D,D,I,D,I,I,I,I,I,I,I]

-- (0.01 secs, 184,224 bytes)

-- λ> length (posicionDeElemento2 (10^4000))

-- 13287

-- (2.80 secs, 7,672,011,280 bytes)

-- λ> length (posicionDeElemento3 (10^4000))

-- 13287

-- (0.03 secs, 19,828,744 bytes)

-- λ> length (posicionDeElemento4 (10^4000))

-- 13287

-- (0.03 secs, 18,231,536 bytes)

-- λ> length (posicionDeElemento3 (10^50000))

-- 166096

-- (1.34 secs, 1,832,738,136 bytes)

-- λ> length (posicionDeElemento4 (10^50000))

-- 166096

-- (1.70 secs, 1,812,806,080 bytes)

Pensamiento

El ojo que ves no es
ojo porque tú lo veas;
es ojo porque te ve.

Antonio Machado

Posiciones en árboles binarios

PorJosé A. Alonso 4-diciembre-201819-enero-2019

Los árboles binarios con datos en los nodos se definen por

   data Arbol a = H
                | N a (Arbol a) (Arbol a)
     deriving (Eq, Show)

data Arbol a = H

| N a (Arbol a) (Arbol a)

deriving (Eq, Show)

Por ejemplo, el árbol

          3
         / \
        /   \
       0     5
      / \   / \
     5   0 0   3
    / \
   2   4

/ \

0 5

/ \ / \

5 0 0 3

/ \

2 4

se representa por

   ejArbol :: Arbol Int
   ejArbol = N 3
               (N 0
                  (N 5
                     (N 2 H H)
                     (N 4 H H))
                  (N 0 H H))
               (N 5
                  (N 0 H H)
                  (N 3 H H))

ejArbol :: Arbol Int

ejArbol = N 3

(N 0

(N 5

(N 2 H H)

(N 4 H H))

(N 0 H H))

(N 5

(N 0 H H)

(N 3 H H))

Cada posición de un elemento de un árbol es una lista de movimientos hacia la izquierda o hacia la derecha. Por ejemplo, la posición de 4 en al árbol anterior es [I,I,D].

Los tipos de los movimientos y de las posiciones se definen por

   data Movimiento = I | D deriving (Show, Eq)
   type Posicion   = [Movimiento]

1 2	data Movimiento = I \| D deriving (Show, Eq) type Posicion = [Movimiento]

Definir la función

   posiciones :: Eq b => b -> Arbol b -> [Posicion]

1	posiciones :: Eq b => b -> Arbol b -> [Posicion]

tal que (posiciones n a) es la lista de las posiciones del elemento n en el árbol a. Por ejemplo,

   posiciones 0 ejArbol  ==  [[I],[I,D],[D,I]]
   posiciones 2 ejArbol  ==  [[I,I,I]]
   posiciones 3 ejArbol  ==  [[],[D,D]]
   posiciones 4 ejArbol  ==  [[I,I,D]]
   posiciones 5 ejArbol  ==  [[I,I],[D]]
   posiciones 1 ejArbol  ==  []

posiciones 0 ejArbol == [[I],[I,D],[D,I]]

posiciones 2 ejArbol == [[I,I,I]]

posiciones 3 ejArbol == [[],[D,D]]

posiciones 4 ejArbol == [[I,I,D]]

posiciones 5 ejArbol == [[I,I],[D]]

posiciones 1 ejArbol == []

Soluciones

data Arbol a = H
             | N a (Arbol a) (Arbol a)
  deriving (Eq, Show)

ejArbol :: Arbol Int
ejArbol = N 3
            (N 0
               (N 5
                  (N 2 H H)
                  (N 4 H H))
               (N 0 H H))
            (N 5
               (N 0 H H)
               (N 3 H H))

data Movimiento = I | D deriving (Show, Eq)

type Posicion = [Movimiento]

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

posiciones :: Eq b => b -> Arbol b -> [Posicion]
posiciones n a = aux n a [[]]
  where aux _ H _                      = []
        aux n (N x i d) cs | x == n    = cs ++
                                         [I:xs | xs <- aux n i cs] ++
                                         [D:xs | xs <- aux n d cs]
                           | otherwise = [I:xs | xs <- aux n i cs] ++
                                         [D:xs | xs <- aux n d cs]
                   
-- 2ª solución
-- ===========

posiciones2 :: Eq b => b -> Arbol b -> [Posicion]
posiciones2 n a = aux n a [[]]
  where aux _ H _                      = []
        aux n (N x i d) cs | x == n    = cs ++ ps
                           | otherwise = ps
          where ps = [I:xs | xs <- aux n i cs] ++
                     [D:xs | xs <- aux n d cs]

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

posiciones3 :: Eq b => b -> Arbol b -> [Posicion]
posiciones3 n a = aux n a [[]]
  where aux _ H _                      = []
        aux n (N x i d) cs | x == n    = cs ++ ps
                           | otherwise = ps
          where ps = map (I:) (aux n i cs) ++
                     map (D:) (aux n d cs)

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

-- Generador de árboles
instance Arbitrary a => Arbitrary (Arbol a) where
  arbitrary = sized genArbol

genArbol :: (Arbitrary a, Integral a1) => a1 -> Gen (Arbol a)
genArbol 0         = return H 
genArbol n | n > 0 = N <$> arbitrary <*> subarbol <*> subarbol
  where subarbol = genArbol (div n 2)

-- La propiedad es
prop_posiciones_equiv :: Arbol Int -> Bool
prop_posiciones_equiv a =
  and [posiciones n a == posiciones2 n a | n <- xs] &&
  and [posiciones n a == posiciones3 n a | n <- xs]  
  where xs = take 3 (elementos a)

-- (elementos a) son los elementos del árbol a. Por ejemplo,
--    elementos ejArbol  ==  [3,0,5,2,4]
elementos :: Eq b => Arbol b -> [b]
elementos H         = []
elementos (N x i d) = nub (x : elementos i ++ elementos d)

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

data Arbol a = H

| N a (Arbol a) (Arbol a)

deriving (Eq, Show)

ejArbol :: Arbol Int

ejArbol = N 3

(N 0

(N 5

(N 2 H H)

(N 4 H H))

(N 0 H H))

(N 5

(N 0 H H)

(N 3 H H))

data Movimiento = I | D deriving (Show, Eq)

type Posicion = [Movimiento]

-- 1ª solución

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

posiciones :: Eq b => b -> Arbol b -> [Posicion]

posiciones n a = aux n a [[]]

where aux _ H _ = []

aux n (N x i d) cs | x == n = cs ++

[I:xs | xs <- aux n i cs] ++

[D:xs | xs <- aux n d cs]

| otherwise = [I:xs | xs <- aux n i cs] ++

[D:xs | xs <- aux n d cs]

-- 2ª solución

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

posiciones2 :: Eq b => b -> Arbol b -> [Posicion]

posiciones2 n a = aux n a [[]]

where aux _ H _ = []

aux n (N x i d) cs | x == n = cs ++ ps

| otherwise = ps

where ps = [I:xs | xs <- aux n i cs] ++

[D:xs | xs <- aux n d cs]

-- 3ª solución

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

posiciones3 :: Eq b => b -> Arbol b -> [Posicion]

posiciones3 n a = aux n a [[]]

where aux _ H _ = []

aux n (N x i d) cs | x == n = cs ++ ps

| otherwise = ps

where ps = map (I:) (aux n i cs) ++

map (D:) (aux n d cs)

-- Equivalencia

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

-- Generador de árboles

instance Arbitrary a => Arbitrary (Arbol a) where

arbitrary = sized genArbol

genArbol :: (Arbitrary a, Integral a1) => a1 -> Gen (Arbol a)

genArbol 0 = return H

genArbol n | n > 0 = N <$> arbitrary <*> subarbol <*> subarbol

where subarbol = genArbol (div n 2)

-- La propiedad es

prop_posiciones_equiv :: Arbol Int -> Bool

prop_posiciones_equiv a =

and [posiciones n a == posiciones2 n a | n <- xs] &&

and [posiciones n a == posiciones3 n a | n <- xs]

where xs = take 3 (elementos a)

-- (elementos a) son los elementos del árbol a. Por ejemplo,

-- elementos ejArbol == [3,0,5,2,4]

elementos :: Eq b => Arbol b -> [b]

elementos H = []

elementos (N x i d) = nub (x : elementos i ++ elementos d)

-- La comprobación es

-- λ> quickCheck prop_posiciones_equiv

-- +++ OK, passed 100 tests.

Pensamiento

Nunca traces tu frontera,
ni cuides de tu perfil;
todo eso es cosa de fuera.

Antonio Machado

Numeración de los árboles binarios completos

PorJosé A. Alonso 3-diciembre-201819-enero-2019

La numeración de los árboles binarios completos se realiza a partir de la raíz, recorriendo los niveles de izquierda a derecha. Por ejemplo,

                  1
                 /  \
                /    \
               /      \
              2        3
             / \      / \
            4   5    6   7
           / \    
          8   9

/ \

2 3

/ \ / \

4 5 6 7

/ \

8 9

Los árboles binarios se puede representar mediante el siguiente tipo

   data Arbol = H
              | N Int Arbol Arbol
     deriving (Show, Eq)

data Arbol = H

| N Int Arbol Arbol

deriving (Show, Eq)

Definir la función

    arbolBinarioCompleto :: Int -> Arbol

1	arbolBinarioCompleto :: Int -> Arbol

tal que (arbolBinarioCompleto n) es el árbol binario completo con n
nodos. Por ejemplo,

   λ> arbolBinarioCompleto 4
   N 1 (N 2 (N 4 H H) H) (N 3 H H)
   λ> arbolBinarioCompleto 9
   N 1
     (N 2
        (N 4
           (N 8 H H)
           (N 9 H H))
        (N 5 H H))
     (N 3
        (N 6 H H)
        (N 7 H H))

λ> arbolBinarioCompleto 4

N 1 (N 2 (N 4 H H) H) (N 3 H H)

λ> arbolBinarioCompleto 9

N 1

(N 2

(N 4

(N 8 H H)

(N 9 H H))

(N 5 H H))

(N 3

(N 6 H H)

(N 7 H H))

Soluciones

data Arbol = H
           | N Int Arbol Arbol
  deriving (Eq, Show)

arbolBinarioCompleto :: Int -> Arbol
arbolBinarioCompleto n = aux 1
  where aux i | i <= n    = N i (aux (2*i)) (aux (2*i+1))
              | otherwise = H

data Arbol = H

| N Int Arbol Arbol

deriving (Eq, Show)

arbolBinarioCompleto :: Int -> Arbol

arbolBinarioCompleto n = aux 1

where aux i | i <= n = N i (aux (2*i)) (aux (2*i+1))

| otherwise = H

Pensamiento

– Ya se oyen palabras viejas.
– Pues aguzad las orejas.

Antonio Machado

Números colinas

PorJosé A. Alonso 29-noviembre-201819-enero-2019

Se dice que un número natural n es una colina si su primer dígito es igual a su último dígito, los primeros dígitos son estrictamente creciente hasta llegar al máximo, el máximo se puede repetir y los dígitos desde el máximo al final son estrictamente decrecientes.

Definir la función

   esColina :: Integer -> Bool

1	esColina :: Integer -> Bool

tal que (esColina n) se verifica si n es un número colina. Por ejemplo,

   esColina 12377731  ==  True
   esColina 1237731   ==  True
   esColina 123731    ==  True
   esColina 122731    ==  False
   esColina 12377730  ==  False
   esColina 12377730  ==  False
   esColina 10377731  ==  False
   esColina 12377701  ==  False
   esColina 33333333  ==  True

esColina 12377731 == True

esColina 1237731 == True

esColina 123731 == True

esColina 122731 == False

esColina 12377730 == False

esColina 10377731 == False

esColina 12377701 == False

esColina 33333333 == True

Soluciones

import Data.Char (digitToInt)

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

esColina :: Integer -> Bool
esColina n =
  head ds == last ds &&
  esCreciente xs &&
  esDecreciente ys
  where ds = digitos n
        m  = maximum ds
        xs = takeWhile (<m) ds
        ys = dropWhile (==m) (dropWhile (<m) ds)

-- (digitos n) es la lista de los dígitos de n. Por ejemplo,
--    digitos 425  ==  [4,2,5]
digitos :: Integer -> [Int]
digitos n = map digitToInt (show n)

-- (esCreciente xs) se verifica si la lista xs es estrictamente
-- creciente. Por ejemplo,
--    esCreciente [2,4,7]  ==  True
--    esCreciente [2,2,7]  ==  False
--    esCreciente [2,1,7]  ==  False
esCreciente :: [Int] -> Bool
esCreciente xs = and [x < y | (x,y) <- zip xs (tail xs)]

-- (esDecreciente xs) se verifica si la lista xs es estrictamente
-- decreciente. Por ejemplo,
--    esDecreciente [7,4,2]  ==  True
--    esDecreciente [7,2,2]  ==  False
--    esDecreciente [7,1,2]  ==  False
esDecreciente :: [Int] -> Bool
esDecreciente xs = and [x > y | (x,y) <- zip xs (tail xs)]

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

esColina2 :: Integer -> Bool
esColina2 n =
  head ds == last ds &&
  null (dropWhile (==(-1)) (dropWhile (==0) (dropWhile (==1) xs)))
  where ds = digitos n
        xs = [signum (y-x) | (x,y) <- zip ds (tail ds)] 

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

-- La propiedad de equivalencia es
prop_esColina :: Integer -> Property
prop_esColina n =
  n >= 0 ==> esColina n == esColina2 n 

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

import Data.Char (digitToInt)

-- 1ª definición

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

esColina :: Integer -> Bool

esColina n =

head ds == last ds &&

esCreciente xs &&

esDecreciente ys

where ds = digitos n

m = maximum ds

xs = takeWhile (<m) ds

ys = dropWhile (==m) (dropWhile (<m) ds)

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

-- digitos 425 == [4,2,5]

digitos :: Integer -> [Int]

digitos n = map digitToInt (show n)

-- (esCreciente xs) se verifica si la lista xs es estrictamente

-- creciente. Por ejemplo,

-- esCreciente [2,4,7] == True

-- esCreciente [2,2,7] == False

-- esCreciente [2,1,7] == False

esCreciente :: [Int] -> Bool

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

-- (esDecreciente xs) se verifica si la lista xs es estrictamente

-- decreciente. Por ejemplo,

-- esDecreciente [7,4,2] == True

-- esDecreciente [7,2,2] == False

-- esDecreciente [7,1,2] == False

esDecreciente :: [Int] -> Bool

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

-- 2ª definición

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

esColina2 :: Integer -> Bool

esColina2 n =

head ds == last ds &&

null (dropWhile (==(-1)) (dropWhile (==0) (dropWhile (==1) xs)))

where ds = digitos n

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

-- Equivalencia

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

-- La propiedad de equivalencia es

prop_esColina :: Integer -> Property

prop_esColina n =

n >= 0 ==> esColina n == esColina2 n

-- La comprobación es

-- λ> quickCheck prop_esColina

-- +++ OK, passed 100 tests.

Referencia

Basado en el problema Is this number a hill number? de Code Golf

Pensamiento

Si me tengo que morir
poco me importa aprender.
Y si no puedo saber,
poco me importa vivir.

Antonio Machado

Capicúas productos de dos números de dos dígitos

PorJosé A. Alonso 16-noviembre-201819-enero-2019

El número 9009 es capicúa y es producto de dos números de dos dígitos, pues 9009 = 91×99.

Definir la lista

   capicuasP2N2D :: [Int]

1	capicuasP2N2D :: [Int]

cuyos elementos son los números capicúas que son producto de 2 números de dos dígitos. Por ejemplo,

   take 5  capicuasP2N2D  ==  [121,242,252,272,323]
   length  capicuasP2N2D  ==  74
   drop 70 capicuasP2N2D  ==  [8008,8118,8448,9009]

take 5 capicuasP2N2D == [121,242,252,272,323]

length capicuasP2N2D == 74

drop 70 capicuasP2N2D == [8008,8118,8448,9009]

Soluciones

import Data.List

capicuasP2N2D :: [Int]
capicuasP2N2D = [x | x <- productos, esCapicua x]

-- productos es la lista de números que son productos de 2 números de
-- dos dígitos.   
productos :: [Int]
productos = sort (nub [x*y | x <- [10..99], y <- [x..99]])

-- (esCapicua x) se verifica si x es capicúa.
esCapicua :: Int -> Bool
esCapicua x = xs == reverse xs
  where xs = show x

import Data.List

capicuasP2N2D :: [Int]

capicuasP2N2D = [x | x <- productos, esCapicua x]

-- productos es la lista de números que son productos de 2 números de

-- dos dígitos.

productos :: [Int]

productos = sort (nub [x*y | x <- [10..99], y <- [x..99]])

-- (esCapicua x) se verifica si x es capicúa.

esCapicua :: Int -> Bool

esCapicua x = xs == reverse xs

where xs = show x

Pensamiento

Ayudadme a comprender lo que os digo, y os lo explicaré más despacio.

Antonio Machado

Número medio

PorJosé A. Alonso 24-julio-201826-marzo-2022

Un número medio es número natural que es igual a la media aritmética de las permutaciones de sus dígitos. Por ejemplo, 370 es un número medio ya que las permutaciones de sus dígitos es 073, 037, 307, 370, 703 y 730 cuya media es 2220/6 que es igual a 370.

Definir las siguientes funciones

   numeroMedio                :: Integer -> Bool
   densidadesNumeroMedio      :: [Double]
   graficaDensidadNumeroMedio :: Int -> IO ()

numeroMedio :: Integer -> Bool

densidadesNumeroMedio :: [Double]

graficaDensidadNumeroMedio :: Int -> IO ()

tales que

(numeroMedio n) se verifica si n es un número medio. Por ejemplo,

      λ> numeroMedio 370
      True
      λ> numeroMedio 371
      False
      λ> numeroMedio 485596707818930041152263374
      True
      λ> filter numeroMedio [100..600]
      [111,222,333,370,407,444,481,518,555,592]
      λ> filter numeroMedio [3*10^5..6*10^5]
      [333333,370370,407407,444444,481481,518518,555555,592592]

λ> numeroMedio 370

True

λ> numeroMedio 371

False

λ> numeroMedio 485596707818930041152263374

True

λ> filter numeroMedio [100..600]

[111,222,333,370,407,444,481,518,555,592]

λ> filter numeroMedio [3*10^5..6*10^5]

[333333,370370,407407,444444,481481,518518,555555,592592]

densidades es la lista cuyo elemento n-ésimo (empezando a contar en 1) es la densidad de números medios en el intervalo [1,n]; es decir, la cantidad de números medios menores o iguales que n dividida por n. Por ejemplo,

      λ> mapM_ print (take 30 densidades)
      1.0
      1.0
      1.0
      1.0
      1.0
      1.0
      1.0
      1.0
      1.0
      0.9
      0.9090909090909091
      0.8333333333333334
      0.7692307692307693
      0.7142857142857143
      0.6666666666666666
      0.625
      0.5882352941176471
      0.5555555555555556
      0.5263157894736842
      0.5
      0.47619047619047616
      0.5
      0.4782608695652174
      0.4583333333333333
      0.44
      0.4230769230769231
      0.4074074074074074
      0.39285714285714285
      0.3793103448275862
      0.36666666666666664

λ> mapM_ print (take 30 densidades)

1.0

0.9

0.9090909090909091

0.8333333333333334

0.7692307692307693

0.7142857142857143

0.6666666666666666

0.625

0.5882352941176471

0.5555555555555556

0.5263157894736842

0.5

0.47619047619047616

0.5

0.4782608695652174

0.4583333333333333

0.44

0.4230769230769231

0.4074074074074074

0.39285714285714285

0.3793103448275862

0.36666666666666664

(graficaDensidadNumeroMedio n) dibuja la gráfica de las densidades de
los intervalos [1,k] para k desde 1 hasta n. Por ejemplo, (graficaDensidadNumeroMedio 100) dibuja

y (graficaDensidadNumeroMedio 1000) dibuja

Soluciones

Puedes escribir tus soluciones en los comentarios o ver las soluciones propuestas pulsando [expand title=»aquí»]

import Data.List (genericLength, permutations, foldl')
import Test.QuickCheck
import Graphics.Gnuplot.Simple 

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

numeroMedio :: Integer -> Bool
numeroMedio n =
  n == media (map digitosAnumero (permutations (digitos n)))

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

-- (digitosAnumero xs) es el número cuya lista de dígitos es xs. Por
-- ejemplo, 
--    digitosAnumero [4,2,5]  ==  425

-- 1ª definición de digitosAnumero
digitosAnumero1 :: [Integer] -> Integer
digitosAnumero1 = aux . reverse
  where aux [] = 0
        aux (x:xs) = x + 10 * aux xs

-- 1ª definición de digitosAnumero
digitosAnumero2 :: [Integer] -> Integer
digitosAnumero2 = foldl' (\x y -> 10*x+y) 0

-- Comparación de eficiencia de definiciones de digitosAnumero
--    λ> length (show (digitosAnumero1 (replicate (10^5) 5)))
--    100000
--    (5.07 secs, 4,317,349,968 bytes)
--    λ> length (show (digitosAnumero2 (replicate (10^5) 5)))
--    100000
--    (0.67 secs, 4,288,054,592 bytes)

-- Se usará la 2ª definición de digitosAnumero
digitosAnumero :: [Integer] -> Integer
digitosAnumero = digitosAnumero2

-- (media xs) es la media aritmética de la lista xs (se supone que su
-- valor es entero). Por ejemplo,
--    media [370,730,73,703,37,307]  ==  370
media :: [Integer] -> Integer
media xs = sum xs `div` genericLength xs

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

numeroMedio2 :: Integer -> Bool
numeroMedio2 n =
  (10^k-1)*s == 9*k*n
  where xs = digitos n
        k  = genericLength xs
        s  = sum xs

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

-- La propiedad es
prop_numeroMedio :: Positive Integer -> Bool
prop_numeroMedio (Positive n) =
  numeroMedio n == numeroMedio2 n

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

-- Comparación de eficiencia de las definiciones de numeroMedio
-- ============================================================

--    λ> filter numeroMedio [10000..20000]
--    [11111]
--    (1.74 secs, 1,500,858,904 bytes)
--    λ> filter numeroMedio2 [10000..20000]
--    [11111]
--    (0.11 secs, 213,060,784 bytes)

-- Definición de densidadesNumeroMedio
-- ===================================

densidadesNumeroMedio :: [Double]
densidadesNumeroMedio = 
  [genericLength (filter numeroMedio2 [1..n]) / fromIntegral n | n <- [1..]]

-- Definición de graficaDensidadNumeroMedio
-- ========================================

graficaDensidadNumeroMedio :: Int -> IO ()
graficaDensidadNumeroMedio n =
  plotList [ Title ("graficaDensidadNumeroMedio")
           , Key Nothing
           -- , PNG ("Numero_medio_" ++ show n ++ ".png" )
           , XRange (1, fromIntegral n)]
           (take n densidadesNumeroMedio)

import Data.List (genericLength, permutations, foldl')

import Test.QuickCheck

import Graphics.Gnuplot.Simple

-- 1ª definición de numeroMedio

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

numeroMedio :: Integer -> Bool

numeroMedio n =

n == media (map digitosAnumero (permutations (digitos n)))

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

-- digitos 425 == [4,2,5]

digitos :: Integer -> [Integer]

digitos n =

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

-- (digitosAnumero xs) es el número cuya lista de dígitos es xs. Por

-- ejemplo,

-- digitosAnumero [4,2,5] == 425

-- 1ª definición de digitosAnumero

digitosAnumero1 :: [Integer] -> Integer

digitosAnumero1 = aux . reverse

where aux [] = 0

aux (x:xs) = x + 10 * aux xs

-- 1ª definición de digitosAnumero

digitosAnumero2 :: [Integer] -> Integer

digitosAnumero2 = foldl' (\x y -> 10*x+y) 0

-- Comparación de eficiencia de definiciones de digitosAnumero

-- λ> length (show (digitosAnumero1 (replicate (10^5) 5)))

-- 100000

-- (5.07 secs, 4,317,349,968 bytes)

-- λ> length (show (digitosAnumero2 (replicate (10^5) 5)))

-- 100000

-- (0.67 secs, 4,288,054,592 bytes)

-- Se usará la 2ª definición de digitosAnumero

digitosAnumero :: [Integer] -> Integer

digitosAnumero = digitosAnumero2

-- (media xs) es la media aritmética de la lista xs (se supone que su

-- valor es entero). Por ejemplo,

-- media [370,730,73,703,37,307] == 370

media :: [Integer] -> Integer

media xs = sum xs `div` genericLength xs

-- 2ª definición de numeroMedio

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

numeroMedio2 :: Integer -> Bool

numeroMedio2 n =

(10^k-1)*s == 9*k*n

where xs = digitos n

k = genericLength xs

s = sum xs

-- Equivalencia de las definiciones de numeroMedio

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

-- La propiedad es

prop_numeroMedio :: Positive Integer -> Bool

prop_numeroMedio (Positive n) =

numeroMedio n == numeroMedio2 n

-- La comprobación es

-- λ> quickCheck prop_numeroMedio

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia de las definiciones de numeroMedio

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

-- λ> filter numeroMedio [10000..20000]

-- [11111]

-- (1.74 secs, 1,500,858,904 bytes)

-- λ> filter numeroMedio2 [10000..20000]

-- [11111]

-- (0.11 secs, 213,060,784 bytes)

-- Definición de densidadesNumeroMedio

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

densidadesNumeroMedio :: [Double]

densidadesNumeroMedio =

[genericLength (filter numeroMedio2 [1..n]) / fromIntegral n | n <- [1..]]

-- Definición de graficaDensidadNumeroMedio

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

graficaDensidadNumeroMedio :: Int -> IO ()

graficaDensidadNumeroMedio n =

plotList [ Title ("graficaDensidadNumeroMedio")

, Key Nothing

-- , PNG ("Numero_medio_" ++ show n ++ ".png" )

, XRange (1, fromIntegral n)]

(take n densidadesNumeroMedio)

[/expand]

Tren de potencias

PorJosé A. Alonso 23-julio-201824-julio-2018

Si n es el número natural cuya expansión decimal es abc… , el tren de potencias de n es a^bc^d… donde el último exponente es 1, si n tiene un número impar de dígitos. Por ejemplo

   trenDePotencias 2453  = 2^4*5^3     = 2000
   trenDePotencias 24536 = 2^4*5^3*6^1 = 12000

1 2	trenDePotencias 2453 = 2^45^3 = 2000 trenDePotencias 24536 = 2^45^3*6^1 = 12000

Definir las funciones

   trenDePotencias            :: Integer -> Integer
   esPuntoFijoTrenDePotencias :: Integer -> Bool
   puntosFijosTrenDePotencias :: [Integer]
   tablaTrenDePotencias       :: Integer -> Integer -> IO ()

trenDePotencias :: Integer -> Integer

esPuntoFijoTrenDePotencias :: Integer -> Bool

puntosFijosTrenDePotencias :: [Integer]

tablaTrenDePotencias :: Integer -> Integer -> IO ()

tales que

(trenDePotencias n) es el tren de potencia de n. Por ejemplo.

     trenDePotencias 20   ==  1
     trenDePotencias 21   ==  2
     trenDePotencias 24   ==  16
     trenDePotencias 39   ==  19683
     trenDePotencias 623  ==  108

trenDePotencias 20 == 1

trenDePotencias 21 == 2

trenDePotencias 24 == 16

trenDePotencias 39 == 19683

trenDePotencias 623 == 108

(esPuntoFijoTrenDePotencias n) se verifica si n es un punto fijo de trenDePotencias; es decir, (trenDePotencias n) es igual a n. Por ejemplo,

     esPuntoFijoTrenDePotencias 2592                        ==  True
     esPuntoFijoTrenDePotencias 24547284284866560000000000  ==  True

1 2	esPuntoFijoTrenDePotencias 2592 == True esPuntoFijoTrenDePotencias 24547284284866560000000000 == True

puntosFijosTrenDePotencias es la lista de los puntso fijos de trenDePotencias. Por ejemplo,

     take 10 puntosFijosTrenDePotencias  ==  [1,2,3,4,5,6,7,8,9,2592]

1	take 10 puntosFijosTrenDePotencias == [1,2,3,4,5,6,7,8,9,2592]

(tablaTrenDePotencias a b) es la tabla de los trenes de potencias de los números entre a y b. Por ejemplo,

     λ> tablaTrenDePotencias 20 39
     | 20 |     1 |
     | 21 |     2 |
     | 22 |     4 |
     | 23 |     8 |
     | 24 |    16 |
     | 25 |    32 |
     | 26 |    64 |
     | 27 |   128 |
     | 28 |   256 |
     | 29 |   512 |
     | 30 |     1 |
     | 31 |     3 |
     | 32 |     9 |
     | 33 |    27 |
     | 34 |    81 |
     | 35 |   243 |
     | 36 |   729 |
     | 37 |  2187 |
     | 38 |  6561 |
     | 39 | 19683 |
     λ> tablaTrenDePotencias 2340 2359
     | 2340 |        8 |
     | 2341 |       32 |
     | 2342 |      128 |
     | 2343 |      512 |
     | 2344 |     2048 |
     | 2345 |     8192 |
     | 2346 |    32768 |
     | 2347 |   131072 |
     | 2348 |   524288 |
     | 2349 |  2097152 |
     | 2350 |        8 |
     | 2351 |       40 |
     | 2352 |      200 |
     | 2353 |     1000 |
     | 2354 |     5000 |
     | 2355 |    25000 |
     | 2356 |   125000 |
     | 2357 |   625000 |
     | 2358 |  3125000 |
     | 2359 | 15625000 |

λ> tablaTrenDePotencias 20 39

| 20 | 1 |

| 21 | 2 |

| 22 | 4 |

| 23 | 8 |

| 24 | 16 |

| 25 | 32 |

| 26 | 64 |

| 27 | 128 |

| 28 | 256 |

| 29 | 512 |

| 30 | 1 |

| 31 | 3 |

| 32 | 9 |

| 33 | 27 |

| 34 | 81 |

| 35 | 243 |

| 36 | 729 |

| 37 | 2187 |

| 38 | 6561 |

| 39 | 19683 |

λ> tablaTrenDePotencias 2340 2359

| 2340 | 8 |

| 2341 | 32 |

| 2342 | 128 |

| 2343 | 512 |

| 2344 | 2048 |

| 2345 | 8192 |

| 2346 | 32768 |

| 2347 | 131072 |

| 2348 | 524288 |

| 2349 | 2097152 |

| 2350 | 8 |

| 2351 | 40 |

| 2352 | 200 |

| 2353 | 1000 |

| 2354 | 5000 |

| 2355 | 25000 |

| 2356 | 125000 |

| 2357 | 625000 |

| 2358 | 3125000 |

| 2359 | 15625000 |

Comprobar con QuickCheck que entre 2593 y 24547284284866559999999999 la función trenDePotencias no tiene puntos fijos.

Soluciones

Puedes escribir tus soluciones en los comentarios o ver las soluciones propuestas pulsando [expand title=»aquí»]

import Test.QuickCheck
import Text.Printf

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

trenDePotencias :: Integer -> Integer
trenDePotencias = trenDePotenciasLN . digitos

-- (digitos n) es la lista de los dígitos del número n. Por ejemplo,
--    digitos 2018  ==   [2,0,1,8]
digitos :: Integer -> [Integer]
digitos n =
  [read [c] | c <- show n]

-- (trenDePotenciasLN xs) es el tren de potencias de la lista de números
-- xs. Por ejemplo,
--    trenDePotenciasLN [2,4,5,3]    ==   2000
--    trenDePotenciasLN [2,4,5,3,6]  ==   12000
trenDePotenciasLN :: [Integer] -> Integer
trenDePotenciasLN []       = 1
trenDePotenciasLN [x]      = x
trenDePotenciasLN (u:v:ws) = u ^ v * (trenDePotenciasLN ws) 

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

trenDePotencias2 :: Integer -> Integer
trenDePotencias2 = trenDePotenciasLN2 . digitos

-- (trenDePotenciasLN2 xs) es el tren de potencias de la lista de números
-- xs. Por ejemplo,
--    trenDePotenciasLN2 [2,4,5,3]    ==   2000
--    trenDePotenciasLN2 [2,4,5,3,6]  ==   12000
trenDePotenciasLN2 :: [Integer] -> Integer
trenDePotenciasLN2 xs =
  product [x^y | (x,y) <- pares xs]

-- (pares xs) es la lista de los pares de elementos en la posiciones
-- pares y sus siguientes; si la longitud de xs es impar, la segunda
-- componente del último par es 1. Por ejemplo,
--    pares [2,4,5,3]    ==   [(2,4),(5,3)]
--    pares [2,4,5,3,6]  ==   [(2,4),(5,3),(6,1)]
pares :: [Integer] -> [(Integer,Integer)]
pares []       = []
pares [x]      = [(x,1)]
pares (x:y:zs) = (x,y) : pares zs

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

-- La propiedad es
prop_equivalencia :: (Positive Integer) -> Bool
prop_equivalencia (Positive n) =
  trenDePotencias n == trenDePotencias2 n

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

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

--    λ> let n = 2*10^5 in trenDePotencias (read (replicate n '2')) == 2^n
--    True
--    (2.11 secs, 2,224,301,136 bytes)
--    λ> let n = 2*10^5 in trenDePotencias2 (read (replicate n '2')) == 2^n
--    True
--    (2.08 secs, 2,237,749,216 bytes)

-- Definición de esPuntoFijoTrenDePotencias
-- ========================================

esPuntoFijoTrenDePotencias :: Integer -> Bool
esPuntoFijoTrenDePotencias n =
  trenDePotencias n == n

-- Definición de puntosFijosTrenDePotencias
-- ========================================

puntosFijosTrenDePotencias :: [Integer]
puntosFijosTrenDePotencias =
  filter esPuntoFijoTrenDePotencias [1..]

-- Definición de tablaTrenDePotencias
-- ==================================

tablaTrenDePotencias :: Integer -> Integer -> IO ()
tablaTrenDePotencias a b =
  sequence_ [printf cabecera x y | (x,y) <- trenes]
  where trenes  = [(n,trenDePotencias n) | n <- [a..b]]
        m1      = show (1 + length (show b))
        m2      = show (length (show (maximum (map snd trenes))))
        cabecera = concat ["|% ",m1,"d | %", m2,"d |\n"]

-- Comprobación
-- ============

-- La propiedad es
prop_puntosFijos :: Positive Integer -> Property
prop_puntosFijos (Positive n) =
  x < 24547284284866560000000000 ==> not (esPuntoFijoTrenDePotencias x)
  where x = 2593 + n 

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

100

101

102

103

104

105

106

107

import Test.QuickCheck

import Text.Printf

-- 1ª definición de trenDePotencias

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

trenDePotencias :: Integer -> Integer

trenDePotencias = trenDePotenciasLN . digitos

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

-- digitos 2018 == [2,0,1,8]

digitos :: Integer -> [Integer]

digitos n =

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

-- (trenDePotenciasLN xs) es el tren de potencias de la lista de números

-- xs. Por ejemplo,

-- trenDePotenciasLN [2,4,5,3] == 2000

-- trenDePotenciasLN [2,4,5,3,6] == 12000

trenDePotenciasLN :: [Integer] -> Integer

trenDePotenciasLN [] = 1

trenDePotenciasLN [x] = x

trenDePotenciasLN (u:v:ws) = u ^ v * (trenDePotenciasLN ws)

-- 2ª definición de trenDePotencias

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

trenDePotencias2 :: Integer -> Integer

trenDePotencias2 = trenDePotenciasLN2 . digitos

-- (trenDePotenciasLN2 xs) es el tren de potencias de la lista de números

-- xs. Por ejemplo,

-- trenDePotenciasLN2 [2,4,5,3] == 2000

-- trenDePotenciasLN2 [2,4,5,3,6] == 12000

trenDePotenciasLN2 :: [Integer] -> Integer

trenDePotenciasLN2 xs =

product [x^y | (x,y) <- pares xs]

-- (pares xs) es la lista de los pares de elementos en la posiciones

-- pares y sus siguientes; si la longitud de xs es impar, la segunda

-- componente del último par es 1. Por ejemplo,

-- pares [2,4,5,3] == [(2,4),(5,3)]

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

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

pares [] = []

pares [x] = [(x,1)]

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

-- Equivalencia

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

-- La propiedad es

prop_equivalencia :: (Positive Integer) -> Bool

prop_equivalencia (Positive n) =

trenDePotencias n == trenDePotencias2 n

-- La comprobación es

-- λ> quickCheck prop_equivalencia

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- λ> let n = 2*10^5 in trenDePotencias (read (replicate n '2')) == 2^n

-- True

-- (2.11 secs, 2,224,301,136 bytes)

-- λ> let n = 2*10^5 in trenDePotencias2 (read (replicate n '2')) == 2^n

-- True

-- (2.08 secs, 2,237,749,216 bytes)

-- Definición de esPuntoFijoTrenDePotencias

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

esPuntoFijoTrenDePotencias :: Integer -> Bool

esPuntoFijoTrenDePotencias n =

trenDePotencias n == n

-- Definición de puntosFijosTrenDePotencias

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

puntosFijosTrenDePotencias :: [Integer]

puntosFijosTrenDePotencias =

filter esPuntoFijoTrenDePotencias [1..]

-- Definición de tablaTrenDePotencias

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

tablaTrenDePotencias :: Integer -> Integer -> IO ()

tablaTrenDePotencias a b =

sequence_ [printf cabecera x y | (x,y) <- trenes]

where trenes = [(n,trenDePotencias n) | n <- [a..b]]

m1 = show (1 + length (show b))

m2 = show (length (show (maximum (map snd trenes))))

cabecera = concat ["|% ",m1,"d | %", m2,"d |\n"]

-- Comprobación

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

-- La propiedad es

prop_puntosFijos :: Positive Integer -> Property

prop_puntosFijos (Positive n) =

x < 24547284284866560000000000 ==> not (esPuntoFijoTrenDePotencias x)

where x = 2593 + n

-- La comprobación es

-- λ> quickCheck prop_puntosFijos

-- +++ OK, passed 100 tests.

[/expand]

Recorrido en ZigZag

PorJosé A. Alonso 7-junio-20187-julio-2018

El recorrido en ZigZag de una matriz consiste en pasar de la primera fila hasta la última, de izquierda a derecha en las filas impares y de derecha a izquierda en las filas pares, como se indica en la figura.

         /             \
         | 1 -> 2 -> 3 |
         |           | |
         |           v |
         | 4 <- 5 <- 6 |   =>  Recorrido ZigZag: [1,2,3,6,5,4,7,8,9]
         | |           |
         | v           |
         | 7 -> 8 -> 9 |
         \             /

/ \

| 1 -> 2 -> 3 |

| | |

| v |

| 4 <- 5 <- 6 | => Recorrido ZigZag: [1,2,3,6,5,4,7,8,9]

| | |

| v |

| 7 -> 8 -> 9 |

\ /

Definir la función

   recorridoZigZag :: Matrix a -> [a]

1	recorridoZigZag :: Matrix a -> [a]

tal que (recorridoZigZag m) es la lista con los elementos de la matriz m cuando se recorre esta en ZigZag. Por ejemplo,

   λ> recorridoZigZag (fromLists [[1,2,3],[4,5,6],[7,8,9]])
   [1,2,3,6,5,4,7,8,9]
   λ> recorridoZigZag (fromLists [[1,2],[3,4],[5,6],[7,8]])
   [1,2,4,3,5,6,8,7]
   λ> recorridoZigZag (fromLists [[1,2,3,4],[5,6,7,8],[9,10,11,12]])
   [1,2,3,4,8,7,6,5,9,10,11,12]
   λ> recorridoZigZag (fromList 5 4 "Cada paso es la meta")
   "Cadasap o es al meta"
   λ> recorridoZigZag (fromList 4 5 "Cada paso es la meta")
   "Cada  osapes laatem "
   λ> recorridoZigZag (fromList 10 2 "Cada paso es la meta")
   "Caad psao se l ameat"
   λ> recorridoZigZag (fromList 2 10 "Cada paso es la meta")
   "Cada paso atem al se"

λ> recorridoZigZag (fromLists [[1,2,3],[4,5,6],[7,8,9]])

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

λ> recorridoZigZag (fromLists [[1,2],[3,4],[5,6],[7,8]])

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

λ> recorridoZigZag (fromLists [[1,2,3,4],[5,6,7,8],[9,10,11,12]])

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

λ> recorridoZigZag (fromList 5 4 "Cada paso es la meta")

"Cadasap o es al meta"

λ> recorridoZigZag (fromList 4 5 "Cada paso es la meta")

"Cada osapes laatem "

λ> recorridoZigZag (fromList 10 2 "Cada paso es la meta")

"Caad psao se l ameat"

λ> recorridoZigZag (fromList 2 10 "Cada paso es la meta")

"Cada paso atem al se"

Soluciones

import Data.Matrix (Matrix, toLists, fromLists, fromList)

recorridoZigZag :: Matrix a -> [a]
recorridoZigZag m =
  concat [f xs | (f,xs) <- zip (cycle [id,reverse]) (toLists m)]

import Data.Matrix (Matrix, toLists, fromLists, fromList)

recorridoZigZag :: Matrix a -> [a]

recorridoZigZag m =

concat [f xs | (f,xs) <- zip (cycle [id,reverse]) (toLists m)]

Valores de polinomios y de expresiones

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

Las expresiones aritméticas construidas con una variables, los números enteros y las operaciones de sumar y multiplicar se pueden representar mediante el tipo de datos Exp definido por

   data Exp = Var | Const Int | Sum Exp Exp | Mul Exp  Exp
              deriving Show

1 2	data Exp = Var \| Const Int \| Sum Exp Exp \| Mul Exp Exp deriving Show

Por ejemplo, la expresión 3+5x^2 se puede representar por

   exp1 :: Exp
   exp1 = Sum (Const 3) (Mul Var (Mul Var (Const 5)))

1 2	exp1 :: Exp exp1 = Sum (Const 3) (Mul Var (Mul Var (Const 5)))

Por su parte, los polinomios se pueden representar por la lista de sus
coeficientes. Por ejemplo, el polinomio 3+5x^2 se puede representar por [3,0,5].

Definir las funciones

   valorE :: Exp -> Int -> Int
   expresion :: [Int] -> Exp
   valorP :: [Int] -> Int -> Int

valorE :: Exp -> Int -> Int

expresion :: [Int] -> Exp

valorP :: [Int] -> Int -> Int

tales que

(valorE e n) es el valor de la expresión e cuando se sustituye su variable por n. Por ejemplo,

     λ> valorE (Sum (Const 3) (Mul Var (Mul Var (Const 5)))) 2
     23

1 2	λ> valorE (Sum (Const 3) (Mul Var (Mul Var (Const 5)))) 2 23

(expresion p) es una expresión aritmética equivalente al polinomio p. Por ejemplo,

     λ> expresion [3,0,5]
     Sum (Const 3) (Mul Var (Sum (Const 0) (Mul Var (Const 5))))

1 2	λ> expresion [3,0,5] Sum (Const 3) (Mul Var (Sum (Const 0) (Mul Var (Const 5))))

(valorP p n) es el valor del polinomio p cuando se sustituye su variable por n. Por ejemplo,

     λ> valorP [3,0,5] 2
     23

1 2	λ> valorP [3,0,5] 2 23

Comprobar con QuickCheck que, para todo polinomio p y todo entero n,

   valorP p n == valorE (expresion p) n

1	valorP p n == valorE (expresion p) n

Soluciones

import Test.QuickCheck

data Exp = Var | Const Int | Sum Exp Exp | Mul Exp  Exp
           deriving Show
 
exp1 :: Exp
exp1 = Sum (Const 3) (Mul Var (Mul Var (Const 5)))
 
valorE :: Exp -> Int -> Int
valorE Var         n = n
valorE (Const a)   n = a
valorE (Sum e1 e2) n = valorE e1 n + valorE e2 n
valorE (Mul e1 e2) n = valorE e1 n * valorE e2 n
 
expresion :: [Int] -> Exp
expresion [a]   = Const a
expresion (a:p) = Sum (Const a) (Mul Var (expresion p))
 
valorP :: [Int] -> Int -> Int
valorP [a] _ = a
valorP (a:p) n = a + n * valorP p n
 
-- La propiedad es
prop_valor :: [Int] -> Int -> Property
prop_valor p n =
    not (null p) ==> 
    valorP p n == valorE (expresion p) n
 
-- La comprobación es
--    λ> quickCheck prop_valor
--    +++ OK, passed 100 tests.

import Test.QuickCheck

data Exp = Var | Const Int | Sum Exp Exp | Mul Exp Exp

deriving Show

exp1 :: Exp

exp1 = Sum (Const 3) (Mul Var (Mul Var (Const 5)))

valorE :: Exp -> Int -> Int

valorE Var n = n

valorE (Const a) n = a

valorE (Sum e1 e2) n = valorE e1 n + valorE e2 n

valorE (Mul e1 e2) n = valorE e1 n * valorE e2 n

expresion :: [Int] -> Exp

expresion [a] = Const a

expresion (a:p) = Sum (Const a) (Mul Var (expresion p))

valorP :: [Int] -> Int -> Int

valorP [a] _ = a

valorP (a:p) n = a + n * valorP p n

-- La propiedad es

prop_valor :: [Int] -> Int -> Property

prop_valor p n =

not (null p) ==>

valorP p n == valorE (expresion p) n

-- La comprobación es

-- λ> quickCheck prop_valor

-- +++ OK, passed 100 tests.

Ancestro común más bajo

PorJosé A. Alonso 1-junio-201811-junio-2018

El tipo de los árboles binarios se define por

   data Arbol = H Int
              | N Int Arbol Arbol

1 2	data Arbol = H Int \| N Int Arbol Arbol

Por ejemplo, el árbol

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

/ \

3 7

/ \ / \

1 4 6 9

se define por

   ejArbol :: Arbol
   ejArbol = N 5 (N 3 (H 1) (H 4)) (N 7 (H 6) (H 9))

1 2	ejArbol :: Arbol ejArbol = N 5 (N 3 (H 1) (H 4)) (N 7 (H 6) (H 9))

Un árbol ordenado es un árbol binario tal que para cada nodo, los elementos de su subárbol izquierdo son menores y los de su subárbol derecho son mayores. El árbol anterior es un árbol ordenado.

Los ancestros de un nodo x son los nodos y tales que x está en alguna de las ramas de x. Por ejemplo, en el árbol anterior los ancestros de 9 son 5 y 7.

El ancestro común más bajo de dos elementos x e y de un árbol a es el ancestro de x e y de menor profundidad. Por ejemplo, en el árbol anterior el ancestro común más bajo de 6 y 9 es 7.

Definir la función

   ancestroComunMasBajo :: Arbol -> Int -> Int -> Int

1	ancestroComunMasBajo :: Arbol -> Int -> Int -> Int

tal que (ancestroComunMasBajo a x y) es el ancestro de menor profundidad de los nodos x e y en el árbol ordenado a, donde x e y son dos elementos distintos del árbol a. Por ejemplo,

   ancestroComunMasBajo ejArbol 4 1  ==  3
   ancestroComunMasBajo ejArbol 1 6  ==  5
   ancestroComunMasBajo ejArbol 6 9  ==  7

ancestroComunMasBajo ejArbol 4 1 == 3

ancestroComunMasBajo ejArbol 1 6 == 5

ancestroComunMasBajo ejArbol 6 9 == 7

Soluciones

data Arbol = H Int
           | N Int Arbol Arbol

ejArbol :: Arbol
ejArbol = N 5 (N 3 (H 1) (H 4)) (N 7 (H 6) (H 9))

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

ancestroComunMasBajo1 :: Arbol -> Int -> Int -> Int
ancestroComunMasBajo1 a x y =
  head [u | u <- xs, u `elem` ys]
  where xs = ancestros a x
        ys = ancestros a y

-- (ancestros a x) es la lista de los ancestros de x en el árbol
-- ordenado a, ordenada por profundidad. Por ejemplo,
--    ancestros ejArbol 1 ==  [3,5]
--    ancestros ejArbol 3 ==  [5]
--    ancestros ejArbol 5 ==  []
--    ancestros ejArbol 9 ==  [7,5]
ancestros :: Arbol -> Int -> [Int]
ancestros a y = aux a y []
  where aux (H _)     _ zs = zs
        aux (N x i d) y zs 
          | x == y    = zs
          | y < x     = aux i y (x:zs)
          | otherwise = aux d y (x:zs)

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

ancestroComunMasBajo2 :: Arbol -> Int -> Int -> Int
ancestroComunMasBajo2 (N z i d) x y 
  | x < z && y < z = ancestroComunMasBajo2 i x y 
  | x > z && y > z = ancestroComunMasBajo2 d x y 
  | otherwise      = z

data Arbol = H Int

| N Int Arbol Arbol

ejArbol :: Arbol

ejArbol = N 5 (N 3 (H 1) (H 4)) (N 7 (H 6) (H 9))

-- 1ª definición

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

ancestroComunMasBajo1 :: Arbol -> Int -> Int -> Int

ancestroComunMasBajo1 a x y =

head [u | u <- xs, u `elem` ys]

where xs = ancestros a x

ys = ancestros a y

-- (ancestros a x) es la lista de los ancestros de x en el árbol

-- ordenado a, ordenada por profundidad. Por ejemplo,

-- ancestros ejArbol 1 == [3,5]

-- ancestros ejArbol 3 == [5]

-- ancestros ejArbol 5 == []

-- ancestros ejArbol 9 == [7,5]

ancestros :: Arbol -> Int -> [Int]

ancestros a y = aux a y []

where aux (H _) _ zs = zs

aux (N x i d) y zs

| x == y = zs

| y < x = aux i y (x:zs)

| otherwise = aux d y (x:zs)

-- 2ª definición

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

ancestroComunMasBajo2 :: Arbol -> Int -> Int -> Int

ancestroComunMasBajo2 (N z i d) x y

| x < z && y < z = ancestroComunMasBajo2 i x y

| x > z && y > z = ancestroComunMasBajo2 d x y

| otherwise = z

Números taxicab

PorJosé A. Alonso 29-mayo-20185-junio-2018

Los números taxicab, taxi-cab o números de Hardy-Ramanujan son aquellos números naturales que pueden expresarse como suma de dos cubos de más de una forma.

Alternativamente, se define al n-ésimo número taxicab como el menor número que es suma de dos cubos de n formas.

Definir las siguientes sucesiones

   taxicab  :: [Integer]
   taxicab2 :: [Integer]

1 2	taxicab :: [Integer] taxicab2 :: [Integer]

tales que taxicab es la sucesión de estos números según la primera definición y taxicab2 según la segunda. Por ejemplo,

   take 5 taxicab   ==  [1729,4104,13832,20683,32832]
   take 2 taxicab2  ==  [2,1729]

1 2	take 5 taxicab == [1729,4104,13832,20683,32832] take 2 taxicab2 == [2,1729]

Nota 1. La sucesiones taxicab y taxicab2 se corresponden con las sucesiones A001235 y A011541 de la OEIS.

Nota 2: Este ejercicio ha sido propuesto por Ángel Ruiz Campos.

Soluciones

import Data.List  (find)
import Data.Maybe (fromJust)

taxicab :: [Integer]
taxicab = filter ((> 1) . length . descomposiciones) [1..]

-- (descomposiciones n) es la lista de pares (x,y) tal que x³ + y³ = n.
-- Por ejemplo,
--    descomposiciones 1729  ==  [(10,9),(12,1)]
--    descomposiciones 1728  ==  [(12,0)]
descomposiciones :: Integer -> [(Integer,Integer)]
descomposiciones n =
  [(x,y) | x <- [1..round (fromIntegral n ** (1/3))],
           let z = n - x^3,
           let z' = round (fromIntegral z ** (1/3)),
           z'^3 == z,
           let y = z',
           y <= x]

-- 2ª definición de descomposiciones
descomposiciones2 :: Integer -> [(Integer,Integer)]
descomposiciones2 n =
  [(x,y) | x <- [1..raizEnt n 3],
           let z = n - x^3,
           let y = raizEnt z 3,
           y <= x,    
           y^3 == z]

-- (raizEnt x n) es la raíz entera n-ésima de x; es decir, el mayor
-- número entero y tal que y^n <= x. Por ejemplo, 
--    raizEnt  8 3      ==  2
--    raizEnt  9 3      ==  2
--    raizEnt 26 3      ==  2
--    raizEnt 27 3      ==  3
--    raizEnt (10^50) 2 ==  10000000000000000000000000
-- ---------------------------------------------------------------------

raizEnt :: Integer -> Integer -> Integer
raizEnt x n = aux (1,x)
  where aux (a,b) | d == x    = c
                  | c == a    = c
                  | d < x     = aux (c,b)
                  | otherwise = aux (a,c) 
          where c = (a+b) `div` 2
                d = c^n

taxicab2 :: [Integer]
taxicab2 = aux 1 [2..]
  where aux n xs = fx : aux (n+1) [fx+1..]
          where fx = fromJust (find ((== n) . length . descomposiciones) xs)

import Data.List (find)

import Data.Maybe (fromJust)

taxicab :: [Integer]

taxicab = filter ((> 1) . length . descomposiciones) [1..]

-- (descomposiciones n) es la lista de pares (x,y) tal que x³ + y³ = n.

-- Por ejemplo,

-- descomposiciones 1729 == [(10,9),(12,1)]

-- descomposiciones 1728 == [(12,0)]

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

descomposiciones n =

[(x,y) | x <- [1..round (fromIntegral n ** (1/3))],

let z = n - x^3,

let z' = round (fromIntegral z ** (1/3)),

z'^3 == z,

let y = z',

y <= x]

-- 2ª definición de descomposiciones

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

descomposiciones2 n =

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

let z = n - x^3,

let y = raizEnt z 3,

y <= x,

y^3 == z]

-- (raizEnt x n) es la raíz entera n-ésima de x; es decir, el mayor

-- número entero y tal que y^n <= x. Por ejemplo,

-- raizEnt 8 3 == 2

-- raizEnt 9 3 == 2

-- raizEnt 26 3 == 2

-- raizEnt 27 3 == 3

-- raizEnt (10^50) 2 == 10000000000000000000000000

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

raizEnt :: Integer -> Integer -> Integer

raizEnt x n = aux (1,x)

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

| c == a = c

| d < x = aux (c,b)

| otherwise = aux (a,c)

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

d = c^n

taxicab2 :: [Integer]

taxicab2 = aux 1 [2..]

where aux n xs = fx : aux (n+1) [fx+1..]

where fx = fromJust (find ((== n) . length . descomposiciones) xs)

Descomposiciones de N como sumas de 1, 3 ó 4.

PorJosé A. Alonso 24-mayo-201831-mayo-2018

El número 5 se puede descomponer en 6 formas distintas como sumas cuyos sumandos sean 1, 3 ó 4:

   5 = 1 + 1 + 1 + 1 + 1
   5 = 1 + 1 + 3
   5 = 1 + 3 + 1
   5 = 3 + 1 + 1
   5 = 1 + 4
   5 = 4 + 1

5 = 1 + 1 + 1 + 1 + 1

5 = 1 + 1 + 3

5 = 1 + 3 + 1

5 = 3 + 1 + 1

5 = 1 + 4

5 = 4 + 1

Definir las funciones

   descomposiciones  :: Integer -> [[Integer]]
   nDescomposiciones :: Integer -> Integer

1 2	descomposiciones :: Integer -> [[Integer]] nDescomposiciones :: Integer -> Integer

tales que

(descomposiciones n) es la lista de las descomposiciones de n como sumas cuyos sumandos sean 1, 3 ó 4. Por ejemplo,

      λ> descomposiciones1 4
      [[4],[3,1],[1,3],[1,1,1,1]]
      λ> descomposiciones1 5
      [[4,1],[1,4],[3,1,1],[1,3,1],[1,1,3],[1,1,1,1,1]]
      λ> descomposiciones1 6
      [[3,3],[4,1,1],[1,4,1],[1,1,4],[3,1,1,1],[1,3,1,1],[1,1,3,1],
       [1,1,1,3],[1,1,1,1,1,1]]

λ> descomposiciones1 4

[[4],[3,1],[1,3],[1,1,1,1]]

λ> descomposiciones1 5

[[4,1],[1,4],[3,1,1],[1,3,1],[1,1,3],[1,1,1,1,1]]

λ> descomposiciones1 6

[[3,3],[4,1,1],[1,4,1],[1,1,4],[3,1,1,1],[1,3,1,1],[1,1,3,1],

[1,1,1,3],[1,1,1,1,1,1]]

(nDescomposiciones n) es el número de descomposiciones de n como sumas cuyos sumandos sean 1, 3 ó 4. Por ejemplo,

     nDescomposiciones 5                       ==  6
     nDescomposiciones 10                      ==  64
     nDescomposiciones 20                      ==  7921
     nDescomposiciones 30                      ==  974169
     length (show (nDescomposiciones (10^5)))  ==  20899

nDescomposiciones 5 == 6

nDescomposiciones 10 == 64

nDescomposiciones 20 == 7921

nDescomposiciones 30 == 974169

length (show (nDescomposiciones (10^5))) == 20899

Nota: Se puede usar programación dinámica.

Soluciones

import Data.List (genericLength)
import Data.Array

-- 1ª definición de descomposiciones (espacios de estado)
-- ======================================================

descomposiciones1 :: Integer -> [[Integer]]
descomposiciones1 n = busca [inicial]
  where
    busca []        = []
    busca (e:es)  
      | esFinal n e = e : busca es
      | otherwise   = busca (es ++ sucesores n e)

-- Un estado es la lista de monedas usadas hasta ahora.
type Estado = [Integer] 

-- inicial es el estado inicial del problema; es decir, cuando no se
-- ha usado ninguna moneda.
inicial :: Estado
inicial = []

-- (esFinal n e) es verifica si e es un estado final del problema n. Por
-- ejemplo, 
--    esFinal (8,5,3) (4,4,0)  ==  True
--    esFinal (8,5,3) (4,0,4)  ==  False
esFinal :: Integer -> Estado -> Bool
esFinal n xs = sum xs == n

-- (sucesores n e) es la lista de los sucesores del estado e en el
-- problema n. Por ejemplo, 
--    sucesores (8,5,3) (8,0,0)  ==  [(3,5,0),(5,0,3)]
--    sucesores (8,5,3) (3,5,0)  ==  [(0,5,3),(8,0,0),(3,2,3)]
sucesores :: Integer -> Estado -> [Estado]
sucesores n xs =
     [1:xs | 1 + k <= n]
  ++ [3:xs | 3 + k <= n]
  ++ [4:xs | 4 + k <= n]
  where k = sum xs

-- 2ª definición de descomposiciones (espacios de estado)
-- ======================================================

descomposiciones2 :: Integer -> [[Integer]]
descomposiciones2 n = busca [inicial2 n]
  where
    busca []       = []
    busca (e:es)  
      | esFinal2 e = snd e : busca es
      | otherwise  = busca (es ++ sucesores2 n e)

-- Un estado es una par formado por la cantidad a conseguir y la lista
-- de monedas usadas hasta ahora.
type Estado2 = (Integer,[Integer]) 

-- (inicial2 n) es el estado inicial del problema; es decir, cuando no se
-- ha usado ninguna moneda.
inicial2 :: Integer -> Estado2
inicial2 n = (n,[])

-- (esFinal2 e) es verifica si e es un estado final del problema. Por
-- ejemplo, 
--    esFinal (8,5,3) (4,4,0)  ==  True
--    esFinal (8,5,3) (4,0,4)  ==  False
esFinal2 :: Estado2 -> Bool
esFinal2 (k,_) = k == 0

-- (sucesores2 n e) es la lista de los sucesores del estado e en el
-- problema n. Por ejemplo, 
--    sucesores (8,5,3) (8,0,0)  ==  [(3,5,0),(5,0,3)]
--    sucesores (8,5,3) (3,5,0)  ==  [(0,5,3),(8,0,0),(3,2,3)]
sucesores2 :: Integer -> Estado2 -> [Estado2]
sucesores2 n (k,xs) =
     [(k-1, 1:xs) | k >= 1]
  ++ [(k-3, 3:xs) | k >= 3]
  ++ [(k-4, 4:xs) | k >= 4]

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

descomposiciones3 :: Integer -> [[Integer]]
descomposiciones3 0 = [[]]
descomposiciones3 1 = [[1]]
descomposiciones3 2 = [[1,1]]
descomposiciones3 3 = [[1,1,1],[3]]
descomposiciones3 n =
     [1:xs | xs <- descomposiciones3 (n-1)]
  ++ [3:xs | xs <- descomposiciones3 (n-3)]
  ++ [4:xs | xs <- descomposiciones3 (n-4)]  

-- 4ª definición de descomposiciones (dinámica)
-- ============================================

descomposiciones4 :: Integer -> [[Integer]]
descomposiciones4 n = v!n
  where v = array (0,n) [(i,aux v i) | i <- [0..n]] 
        aux v 0 = [[]]
        aux v 1 = [[1]]
        aux v 2 = [[1,1]]
        aux v 3 = [[1,1,1],[3]]
        aux v k =    map (1:) (v!(k-1))
                  ++ map (3:) (v!(k-3))
                  ++ map (4:) (v!(k-4))

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

nDescomposiciones1 :: Integer -> Integer
nDescomposiciones1 =
  genericLength . descomposiciones1

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

nDescomposiciones2 :: Integer -> Integer
nDescomposiciones2 =
  genericLength . descomposiciones2

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

nDescomposiciones3 :: Integer -> Integer
nDescomposiciones3 =
  genericLength . descomposiciones3

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

nDescomposiciones4 :: Integer -> Integer
nDescomposiciones4 =
  genericLength . descomposiciones4

-- 5ª definición de nDescomposiciones (dinámica)
-- =============================================

nDescomposiciones5 :: Integer -> Integer
nDescomposiciones5 n = v!n
  where v = array (0,n) [(i,aux v i) | i <- [0..n]] 
        aux v 0 = 1
        aux v 1 = 1
        aux v 2 = 1
        aux v 3 = 2
        aux v k = v!(k-1) + v!(k-3) + v!(k-4)

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

--    λ> nDescomposiciones1 20
--    7921
--    (3.21 secs, 3,199,383,064 bytes)
--    λ> nDescomposiciones2 20
--    7921
--    (3.17 secs, 3,176,666,880 bytes)
--    λ> nDescomposiciones3 20
--    7921
--    (0.08 secs, 17,714,152 bytes)
--    
--    λ> nDescomposiciones3 27
--    229970
--    (3.73 secs, 628,730,968 bytes)
--    λ> nDescomposiciones4 27
--    229970
--    (0.45 secs, 111,518,016 bytes)
--    
--    λ> nDescomposiciones4 30
--    974169
--    (2.02 secs, 454,484,992 bytes)
--    λ> nDescomposiciones5 30
--    974169
--    (0.00 secs, 0 bytes)

--    λ> nDescomposiciones2 30
--    974169
--    (2.10 secs, 441,965,208 bytes)
--    λ> nDescomposiciones3 30
--    974169
--    (0.00 secs, 0 bytes)
--    
--    λ> length (show (nDescomposiciones5 (10^5)))
--    20899
--    (3.00 secs, 1,050,991,880 bytes)

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

import Data.List (genericLength)

import Data.Array

-- 1ª definición de descomposiciones (espacios de estado)

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

descomposiciones1 :: Integer -> [[Integer]]

descomposiciones1 n = busca [inicial]

where

busca [] = []

busca (e:es)

| esFinal n e = e : busca es

| otherwise = busca (es ++ sucesores n e)

-- Un estado es la lista de monedas usadas hasta ahora.

type Estado = [Integer]

-- inicial es el estado inicial del problema; es decir, cuando no se

-- ha usado ninguna moneda.

inicial :: Estado

inicial = []

-- (esFinal n e) es verifica si e es un estado final del problema n. Por

-- ejemplo,

-- esFinal (8,5,3) (4,4,0) == True

-- esFinal (8,5,3) (4,0,4) == False

esFinal :: Integer -> Estado -> Bool

esFinal n xs = sum xs == n

-- (sucesores n e) es la lista de los sucesores del estado e en el

-- problema n. Por ejemplo,

-- sucesores (8,5,3) (8,0,0) == [(3,5,0),(5,0,3)]

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

sucesores :: Integer -> Estado -> [Estado]

sucesores n xs =

[1:xs | 1 + k <= n]

++ [3:xs | 3 + k <= n]

++ [4:xs | 4 + k <= n]

where k = sum xs

-- 2ª definición de descomposiciones (espacios de estado)

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

descomposiciones2 :: Integer -> [[Integer]]

descomposiciones2 n = busca [inicial2 n]

where

busca [] = []

busca (e:es)

| esFinal2 e = snd e : busca es

| otherwise = busca (es ++ sucesores2 n e)

-- Un estado es una par formado por la cantidad a conseguir y la lista

-- de monedas usadas hasta ahora.

type Estado2 = (Integer,[Integer])

-- (inicial2 n) es el estado inicial del problema; es decir, cuando no se

-- ha usado ninguna moneda.

inicial2 :: Integer -> Estado2

inicial2 n = (n,[])

-- (esFinal2 e) es verifica si e es un estado final del problema. Por

-- ejemplo,

-- esFinal (8,5,3) (4,4,0) == True

-- esFinal (8,5,3) (4,0,4) == False

esFinal2 :: Estado2 -> Bool

esFinal2 (k,_) = k == 0

-- (sucesores2 n e) es la lista de los sucesores del estado e en el

-- problema n. Por ejemplo,

-- sucesores (8,5,3) (8,0,0) == [(3,5,0),(5,0,3)]

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

sucesores2 :: Integer -> Estado2 -> [Estado2]

sucesores2 n (k,xs) =

[(k-1, 1:xs) | k >= 1]

++ [(k-3, 3:xs) | k >= 3]

++ [(k-4, 4:xs) | k >= 4]

-- 3ª definición de descomposiciones

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

descomposiciones3 :: Integer -> [[Integer]]

descomposiciones3 0 = [[]]

descomposiciones3 1 = [[1]]

descomposiciones3 2 = [[1,1]]

descomposiciones3 3 = [[1,1,1],[3]]

descomposiciones3 n =

[1:xs | xs <- descomposiciones3 (n-1)]

++ [3:xs | xs <- descomposiciones3 (n-3)]

++ [4:xs | xs <- descomposiciones3 (n-4)]

-- 4ª definición de descomposiciones (dinámica)

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

descomposiciones4 :: Integer -> [[Integer]]

descomposiciones4 n = v!n

where v = array (0,n) [(i,aux v i) | i <- [0..n]]

aux v 0 = [[]]

aux v 1 = [[1]]

aux v 2 = [[1,1]]

aux v 3 = [[1,1,1],[3]]

aux v k = map (1:) (v!(k-1))

++ map (3:) (v!(k-3))

++ map (4:) (v!(k-4))

-- 1ª definición de nDescomposiciones

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

nDescomposiciones1 :: Integer -> Integer

nDescomposiciones1 =

genericLength . descomposiciones1

-- 2ª definición de nDescomposiciones

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

nDescomposiciones2 :: Integer -> Integer

nDescomposiciones2 =

genericLength . descomposiciones2

-- 3ª definición de nDescomposiciones

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

nDescomposiciones3 :: Integer -> Integer

nDescomposiciones3 =

genericLength . descomposiciones3

-- 4ª definición de nDescomposiciones

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

nDescomposiciones4 :: Integer -> Integer

nDescomposiciones4 =

genericLength . descomposiciones4

-- 5ª definición de nDescomposiciones (dinámica)

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

nDescomposiciones5 :: Integer -> Integer

nDescomposiciones5 n = v!n

where v = array (0,n) [(i,aux v i) | i <- [0..n]]

aux v 0 = 1

aux v 1 = 1

aux v 2 = 1

aux v 3 = 2

aux v k = v!(k-1) + v!(k-3) + v!(k-4)

-- Comparación de eficiencia

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

-- λ> nDescomposiciones1 20

-- 7921

-- (3.21 secs, 3,199,383,064 bytes)

-- λ> nDescomposiciones2 20

-- 7921

-- (3.17 secs, 3,176,666,880 bytes)

-- λ> nDescomposiciones3 20

-- 7921

-- (0.08 secs, 17,714,152 bytes)

-- λ> nDescomposiciones3 27

-- 229970

-- (3.73 secs, 628,730,968 bytes)

-- λ> nDescomposiciones4 27

-- 229970

-- (0.45 secs, 111,518,016 bytes)

-- λ> nDescomposiciones4 30

-- 974169

-- (2.02 secs, 454,484,992 bytes)

-- λ> nDescomposiciones5 30

-- 974169

-- (0.00 secs, 0 bytes)

-- λ> nDescomposiciones2 30

-- 974169

-- (2.10 secs, 441,965,208 bytes)

-- λ> nDescomposiciones3 30

-- 974169

-- (0.00 secs, 0 bytes)

-- λ> length (show (nDescomposiciones5 (10^5)))

-- 20899

-- (3.00 secs, 1,050,991,880 bytes)

Caminos en un grafo

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

Definir las funciones

   grafo   :: [(Int,Int)] -> Grafo Int Int
   caminos :: Grafo Int Int -> Int -> Int -> [[Int]]

1 2	grafo :: [(Int,Int)] -> Grafo Int Int caminos :: Grafo Int Int -> Int -> Int -> [[Int]]

tales que

(grafo as) es el grafo no dirigido definido cuyas aristas son as. Por ejemplo,

     ghci> grafo [(2,4),(4,5)]
     G ND (array (2,5) [(2,[(4,0)]),(3,[]),(4,[(2,0),(5,0)]),(5,[(4,0)])])

1 2	ghci> grafo [(2,4),(4,5)] G ND (array (2,5) [(2,[(4,0)]),(3,[]),(4,[(2,0),(5,0)]),(5,[(4,0)])])

(caminos g a b) es la lista los caminos en el grafo g desde a hasta b sin pasar dos veces por el mismo nodo. Por ejemplo,

     ghci> sort (caminos (grafo [(1,3),(2,5),(3,5),(3,7),(5,7)]) 1 7)
     [[1,3,5,7],[1,3,7]]
     ghci> sort (caminos (grafo [(1,3),(2,5),(3,5),(3,7),(5,7)]) 2 7)
     [[2,5,3,7],[2,5,7]]
     ghci> sort (caminos (grafo [(1,3),(2,5),(3,5),(3,7),(5,7)]) 1 2)
     [[1,3,5,2],[1,3,7,5,2]]
     ghci> caminos (grafo [(1,3),(2,5),(3,5),(3,7),(5,7)]) 1 4
     []
     ghci> length (caminos (grafo [(i,j) | i <- [1..10], j <- [i..10]]) 1 10)
     109601

ghci> sort (caminos (grafo [(1,3),(2,5),(3,5),(3,7),(5,7)]) 1 7)

[[1,3,5,7],[1,3,7]]

ghci> sort (caminos (grafo [(1,3),(2,5),(3,5),(3,7),(5,7)]) 2 7)

[[2,5,3,7],[2,5,7]]

ghci> sort (caminos (grafo [(1,3),(2,5),(3,5),(3,7),(5,7)]) 1 2)

[[1,3,5,2],[1,3,7,5,2]]

ghci> caminos (grafo [(1,3),(2,5),(3,5),(3,7),(5,7)]) 1 4

[]

ghci> length (caminos (grafo [(i,j) | i <- [1..10], j <- [i..10]]) 1 10)

109601

Soluciones

import Data.List (sort)
import I1M.Grafo
import I1M.BusquedaEnEspaciosDeEstados

grafo :: [(Int,Int)] -> Grafo Int Int
grafo as = creaGrafo ND (m,n) [(x,y,0) | (x,y) <- as]
    where ns = map fst as ++ map snd as
          m  = minimum ns
          n  = maximum ns

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

caminos :: Grafo Int Int -> Int -> Int -> [[Int]]
caminos g a b = aux [[b]] where 
    aux [] = []
    aux ((x:xs):yss)
        | x == a    = (x:xs) : aux yss
        | otherwise = aux ([z:x:xs | z <- adyacentes g x
                                   , z `notElem` (x:xs)] 
                           ++ yss) 

-- 2ª solución (mediante espacio de estados)
-- =========================================

caminos2 :: Grafo Int Int -> Int -> Int -> [[Int]]
caminos2 g a b = buscaEE sucesores esFinal inicial
    where inicial          = [b]
          sucesores (x:xs) = [z:x:xs | z <- adyacentes g x
                                     , z `notElem` (x:xs)] 
          esFinal (x:xs)   = x == a

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

--    ghci> length (caminos (grafo [(i,j) | i <- [1..10], j <- [i..10]]) 1 10)
--    109601
--    (3.57 secs, 500533816 bytes)
--    ghci> length (caminos2 (grafo [(i,j) | i <- [1..10], j <- [i..10]]) 1 10)
--    109601
--    (3.53 secs, 470814096 bytes)

import Data.List (sort)

import I1M.Grafo

import I1M.BusquedaEnEspaciosDeEstados

grafo :: [(Int,Int)] -> Grafo Int Int

grafo as = creaGrafo ND (m,n) [(x,y,0) | (x,y) <- as]

where ns = map fst as ++ map snd as

m = minimum ns

n = maximum ns

-- 1ª solución

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

caminos :: Grafo Int Int -> Int -> Int -> [[Int]]

caminos g a b = aux [[b]] where

aux [] = []

aux ((x:xs):yss)

| x == a = (x:xs) : aux yss

| otherwise = aux ([z:x:xs | z <- adyacentes g x

, z `notElem` (x:xs)]

++ yss)

-- 2ª solución (mediante espacio de estados)

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

caminos2 :: Grafo Int Int -> Int -> Int -> [[Int]]

caminos2 g a b = buscaEE sucesores esFinal inicial

where inicial = [b]

sucesores (x:xs) = [z:x:xs | z <- adyacentes g x

, z `notElem` (x:xs)]

esFinal (x:xs) = x == a

-- Comparación de eficiencia

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

-- ghci> length (caminos (grafo [(i,j) | i <- [1..10], j <- [i..10]]) 1 10)

-- 109601

-- (3.57 secs, 500533816 bytes)

-- ghci> length (caminos2 (grafo [(i,j) | i <- [1..10], j <- [i..10]]) 1 10)

-- 109601

-- (3.53 secs, 470814096 bytes)

Problema del dominó

PorJosé A. Alonso 16-mayo-201823-mayo-2018

Las fichas del dominó se pueden representar por pares de números enteros. El problema del dominó consiste en colocar todas las fichas de una lista dada de forma que el segundo número de cada ficha coincida con el primero de la siguiente.

Definir la función

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

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

tal que (domino fs) es la lista de las soluciones del problema del dominó correspondiente a las fichas fs. Por ejemplo,

   λ> domino [(1,2),(2,3),(1,4)]
   [[(4,1),(1,2),(2,3)],[(3,2),(2,1),(1,4)]]
   λ> domino [(1,2),(1,1),(1,4)]
   [[(4,1),(1,1),(1,2)],[(2,1),(1,1),(1,4)]]
   λ> domino [(1,2),(3,4),(2,3)]
   [[(1,2),(2,3),(3,4)]]
   λ> domino [(1,2),(2,3),(5,4)]
   []
   λ> domino [(x,y) | x <- [1..2], y <- [x..2]]
   [[(2,2),(2,1),(1,1)],[(1,1),(1,2),(2,2)]]
   λ> [(x,y) | x <- [1..3], y <- [x..3]]
   [(1,1),(1,2),(1,3),(2,2),(2,3),(3,3)]
   λ> mapM_ print (domino [(x,y) | x <- [1..3], y <- [x..3]])
   [(1,3),(3,3),(3,2),(2,2),(2,1),(1,1)]
   [(1,2),(2,2),(2,3),(3,3),(3,1),(1,1)]
   [(2,2),(2,3),(3,3),(3,1),(1,1),(1,2)]
   [(3,3),(3,2),(2,2),(2,1),(1,1),(1,3)]
   [(2,3),(3,3),(3,1),(1,1),(1,2),(2,2)]
   [(2,1),(1,1),(1,3),(3,3),(3,2),(2,2)]
   [(3,3),(3,1),(1,1),(1,2),(2,2),(2,3)]
   [(3,2),(2,2),(2,1),(1,1),(1,3),(3,3)]
   [(3,1),(1,1),(1,2),(2,2),(2,3),(3,3)]
   λ> length (domino [(x,y) | x <- [1..3], y <- [x..3]])
   9
   λ> length (domino [(x,y) | x <- [1..4], y <- [x..4]])
   0
   λ> length (domino [(x,y) | x <- [1..5], y <- [x..5]])
   84480

λ> domino [(1,2),(2,3),(1,4)]

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

λ> domino [(1,2),(1,1),(1,4)]

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

λ> domino [(1,2),(3,4),(2,3)]

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

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

[]

λ> domino [(x,y) | x <- [1..2], y <- [x..2]]

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

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

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

λ> mapM_ print (domino [(x,y) | x <- [1..3], y <- [x..3]])

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

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

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

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

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

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

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

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

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

λ> length (domino [(x,y) | x <- [1..3], y <- [x..3]])

λ> length (domino [(x,y) | x <- [1..4], y <- [x..4]])

λ> length (domino [(x,y) | x <- [1..5], y <- [x..5]])

84480

Soluciones

import I1M.BusquedaEnEspaciosDeEstados (buscaEE)
import Data.List (delete)

-- 1ª solución (por búsqueda en anchura)
-- =====================================

-- Las fichas son pares de números enteros.
type Ficha  = (Int,Int)

-- Un problema está definido por la lista de fichas que hay que colocar
type Problema = [Ficha]

-- Los estados son los pares formados por la listas sin colocar y las
-- colocadas. 
type Estado = ([Ficha],[Ficha])

-- (inicial p) es el estado inicial del problema p.
inicial :: Problema -> Estado
inicial p = (p,[])

-- (es final e) se verifica si e es un estado final.
esFinal :: Estado -> Bool
esFinal (fs,_) = null fs 

sucesores :: Estado -> [Estado]
sucesores (fs,[]) =
  [(delete f fs, [f]) | f <- fs]
sucesores (fs,n@((x,y):qs)) =
  [(delete (u,v) fs,(u,v):n) | (u,v) <- fs, u /= v, v == x] ++
  [(delete (u,v) fs,(v,u):n) | (u,v) <- fs, u /= v, u == x] ++
  [(delete (u,v) fs,(u,v):n) | (u,v) <- fs, u == v, u == x] 

soluciones :: Problema -> [Estado]
soluciones p = busca [(inicial p)]
  where
    busca []        = []
    busca (e:es)  
      | esFinal e = e : busca es
      | otherwise = busca (es ++ sucesores e)

domino :: Problema -> [[Ficha]]
domino ps = map snd (soluciones ps)
      
-- 2ª solución (por búsqueda en profundidad)
-- =========================================

soluciones2 :: Problema -> [Estado]
soluciones2 p = busca [(inicial p)]
  where
    busca []        = []
    busca (e:es)  
      | esFinal e = e : busca es
      | otherwise = busca (sucesores e ++ es)

domino2 :: Problema -> [[Ficha]]
domino2 ps = map snd (soluciones2 ps)
      
-- 3ª solución (con I1M.BusquedaEnEspaciosDeEstados)
-- =================================================

domino3 :: Problema -> [[Ficha]]
domino3 ps = map snd (soluciones3 ps)

soluciones3 :: Problema -> [Estado]
soluciones3 ps = buscaEE sucesores
                         esFinal         
                         (inicial ps)

import I1M.BusquedaEnEspaciosDeEstados (buscaEE)

import Data.List (delete)

-- 1ª solución (por búsqueda en anchura)

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

-- Las fichas son pares de números enteros.

type Ficha = (Int,Int)

-- Un problema está definido por la lista de fichas que hay que colocar

type Problema = [Ficha]

-- Los estados son los pares formados por la listas sin colocar y las

-- colocadas.

type Estado = ([Ficha],[Ficha])

-- (inicial p) es el estado inicial del problema p.

inicial :: Problema -> Estado

inicial p = (p,[])

-- (es final e) se verifica si e es un estado final.

esFinal :: Estado -> Bool

esFinal (fs,_) = null fs

sucesores :: Estado -> [Estado]

sucesores (fs,[]) =

[(delete f fs, [f]) | f <- fs]

sucesores (fs,n@((x,y):qs)) =

[(delete (u,v) fs,(u,v):n) | (u,v) <- fs, u /= v, v == x] ++

[(delete (u,v) fs,(v,u):n) | (u,v) <- fs, u /= v, u == x] ++

[(delete (u,v) fs,(u,v):n) | (u,v) <- fs, u == v, u == x]

soluciones :: Problema -> [Estado]

soluciones p = busca [(inicial p)]

where

busca [] = []

busca (e:es)

| esFinal e = e : busca es

| otherwise = busca (es ++ sucesores e)

domino :: Problema -> [[Ficha]]

domino ps = map snd (soluciones ps)

-- 2ª solución (por búsqueda en profundidad)

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

soluciones2 :: Problema -> [Estado]

soluciones2 p = busca [(inicial p)]

where

busca [] = []

busca (e:es)

| esFinal e = e : busca es

| otherwise = busca (sucesores e ++ es)

domino2 :: Problema -> [[Ficha]]

domino2 ps = map snd (soluciones2 ps)

-- 3ª solución (con I1M.BusquedaEnEspaciosDeEstados)

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

domino3 :: Problema -> [[Ficha]]

domino3 ps = map snd (soluciones3 ps)

soluciones3 :: Problema -> [Estado]

soluciones3 ps = buscaEE sucesores

esFinal

(inicial ps)

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úmero de triangulaciones de un polígono

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

Una triangulación de un polígono es una división del área en un conjunto de triángulos, de forma que la unión de todos ellos es igual al polígono original, y cualquier par de triángulos es disjunto o comparte únicamente un vértice o un lado. En el caso de polígonos convexos, la cantidad de triangulaciones posibles depende únicamente del número de vértices del polígono.

Si llamamos T(n) al número de triangulaciones de un polígono de n vértices, se verifica la siguiente relación de recurrencia:

    T(2) = 1
    T(n) = T(2)*T(n-1) + T(3)*T(n-2) + ... + T(n-1)*T(2)

1 2	T(2) = 1 T(n) = T(2)T(n-1) + T(3)T(n-2) + ... + T(n-1)*T(2)

Definir la función

   numeroTriangulaciones :: Integer -> Integer

1	numeroTriangulaciones :: Integer -> Integer

tal que (numeroTriangulaciones n) es el número de triangulaciones de un polígono convexo de n vértices. Por ejemplo,

   numeroTriangulaciones 3  == 1
   numeroTriangulaciones 5  == 5
   numeroTriangulaciones 6  == 14
   numeroTriangulaciones 7  == 42
   numeroTriangulaciones 50 == 131327898242169365477991900
   length (show (numeroTriangulaciones   800)) ==  476
   length (show (numeroTriangulaciones  1000)) ==  597
   length (show (numeroTriangulaciones 10000)) == 6014

numeroTriangulaciones 3 == 1

numeroTriangulaciones 5 == 5

numeroTriangulaciones 6 == 14

numeroTriangulaciones 7 == 42

numeroTriangulaciones 50 == 131327898242169365477991900

length (show (numeroTriangulaciones 800)) == 476

length (show (numeroTriangulaciones 1000)) == 597

length (show (numeroTriangulaciones 10000)) == 6014

Soluciones

import Data.Array (Array, (!), array)
import Data.List  (genericIndex)
import qualified Data.Vector as V

-- 1ª solución (por recursión)
-- ===========================

numeroTriangulaciones :: Integer -> Integer
numeroTriangulaciones 2 = 1
numeroTriangulaciones n = sum (zipWith (*) ts (reverse ts))
  where ts = [numeroTriangulaciones k | k <- [2..n-1]]

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

--    λ> map numeroTriangulaciones2 [2..15]
--    [1,1,2,5,14,42,132,429,1430,4862,16796,58786,208012,742900]
numeroTriangulaciones2 :: Integer -> Integer
numeroTriangulaciones2 n = 
  head (sucNumeroTriangulacionesInversas `genericIndex` (n-2))

--    λ> mapM_ print (take 10 sucNumeroTriangulacionesInversas)
--    [1]
--    [1,1]
--    [2,1,1]
--    [5,2,1,1]
--    [14,5,2,1,1]
--    [42,14,5,2,1,1]
--    [132,42,14,5,2,1,1]
--    [429,132,42,14,5,2,1,1]
--    [1430,429,132,42,14,5,2,1,1]
--    [4862,1430,429,132,42,14,5,2,1,1]
sucNumeroTriangulacionesInversas :: [[Integer]]        
sucNumeroTriangulacionesInversas = iterate f [1]
  where f ts = sum (zipWith (*) ts (reverse ts)) : ts

-- 3ª solución (con programación dinámica)
-- =======================================

numeroTriangulaciones3 :: Integer -> Integer
numeroTriangulaciones3 n = vectorTriang n ! n

--    λ> vectorTriang 9
--    array (2,9) [(2,1),(3,1),(4,2),(5,5),(6,14),(7,42),(8,132),(9,429)]
vectorTriang :: Integer -> Array Integer Integer
vectorTriang n = v
  where v = array (2,n) [(i, f i) | i <-[2..n]]
        f 2 = 1
        f i = sum [v!j*v!(i-j+1) | j <-[2..i-1]]

-- 4ª solución (con los números de Catalan)
-- ========================================

-- Al calcular por primeros números de triangulaciones se obtiene
--    λ> map numeroTriangulaciones [2..12]
--    [1,1,2,5,14,42,132,429,1430,4862,16796]
-- Se observa que se corresponden con los números de Catalan
-- http://bit.ly/2FOc1S1
-- 
-- El n-ésimo número de Catalan es
--    (2n)! / (n! * (n+1)!)
-- El número de triangulaciones de un polígono de n lados es el
-- (n-2)-ésimo número de Catalan.

numeroTriangulaciones4 :: Integer -> Integer
numeroTriangulaciones4 n = numeroCatalan (n-2) 

numeroCatalan :: Integer -> Integer
numeroCatalan n =
  factorial (2*n) `div` (factorial (n+1) * factorial n)

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

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

numeroTriangulaciones5 :: Integer -> Integer
numeroTriangulaciones5 n = v V.! (m-2)
   where v = V.constructN m
           (\w -> if   V.null w then 1
                  else V.sum (V.zipWith (*) w (V.reverse w)))
         m = fromIntegral n


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

numeroTriangulaciones6 :: Integer -> Integer
numeroTriangulaciones6 n = nCr (2*n-4, n-2) `div` (n-1)
  where nCr (n,m)   = factorial n `div` (factorial (n-m) * factorial m)
        factorial n = product [1..n]

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

--    λ> numeroTriangulaciones 22
--    6564120420
--    (3.97 secs, 668,070,936 bytes)
--    λ> numeroTriangulaciones2 22
--    6564120420
--    (0.01 secs, 180,064 bytes)
--    λ> numeroTriangulaciones3 22
--    6564120420
--    (0.01 secs, 285,792 bytes)
--    
--    λ> length (show (numeroTriangulaciones2 800))
--    476
--    (0.59 secs, 125,026,824 bytes)
--    λ> length (show (numeroTriangulaciones3 800))
--    476
--    (1.95 secs, 334,652,936 bytes)
--    λ> length (show (numeroTriangulaciones4 800))
--    476
--    (0.01 secs, 2,960,088 bytes)
--    λ> length (show (numeroTriangulaciones5 800))
--    476
--    (0.65 secs, 200,415,640 bytes)
--    λ> length (show (numeroTriangulaciones6 800))
--    476
--    (0.01 secs, 2,960,224 bytes)
--    
--    λ> length (show (numeroTriangulaciones4 (10^4)))
--    6014
--    (1.80 secs, 542,364,320 bytes)
--    λ> length (show (numeroTriangulaciones6 (10^4)))
--    6014
--    (1.87 secs, 542,351,136 bytes)

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

import Data.Array (Array, (!), array)

import Data.List (genericIndex)

import qualified Data.Vector as V

-- 1ª solución (por recursión)

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

numeroTriangulaciones :: Integer -> Integer

numeroTriangulaciones 2 = 1

numeroTriangulaciones n = sum (zipWith (*) ts (reverse ts))

where ts = [numeroTriangulaciones k | k <- [2..n-1]]

-- 2ª solución

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

-- λ> map numeroTriangulaciones2 [2..15]

-- [1,1,2,5,14,42,132,429,1430,4862,16796,58786,208012,742900]

numeroTriangulaciones2 :: Integer -> Integer

numeroTriangulaciones2 n =

head (sucNumeroTriangulacionesInversas `genericIndex` (n-2))

-- λ> mapM_ print (take 10 sucNumeroTriangulacionesInversas)

-- [1]

-- [1,1]

-- [2,1,1]

-- [5,2,1,1]

-- [14,5,2,1,1]

-- [42,14,5,2,1,1]

-- [132,42,14,5,2,1,1]

-- [429,132,42,14,5,2,1,1]

-- [1430,429,132,42,14,5,2,1,1]

-- [4862,1430,429,132,42,14,5,2,1,1]

sucNumeroTriangulacionesInversas :: [[Integer]]

sucNumeroTriangulacionesInversas = iterate f [1]

where f ts = sum (zipWith (*) ts (reverse ts)) : ts

-- 3ª solución (con programación dinámica)

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

numeroTriangulaciones3 :: Integer -> Integer

numeroTriangulaciones3 n = vectorTriang n ! n

-- λ> vectorTriang 9

-- array (2,9) [(2,1),(3,1),(4,2),(5,5),(6,14),(7,42),(8,132),(9,429)]

vectorTriang :: Integer -> Array Integer Integer

vectorTriang n = v

where v = array (2,n) [(i, f i) | i <-[2..n]]

f 2 = 1

f i = sum [v!j*v!(i-j+1) | j <-[2..i-1]]

-- 4ª solución (con los números de Catalan)

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

-- Al calcular por primeros números de triangulaciones se obtiene

-- λ> map numeroTriangulaciones [2..12]

-- [1,1,2,5,14,42,132,429,1430,4862,16796]

-- Se observa que se corresponden con los números de Catalan

-- http://bit.ly/2FOc1S1

-- El n-ésimo número de Catalan es

-- (2n)! / (n! * (n+1)!)

-- El número de triangulaciones de un polígono de n lados es el

-- (n-2)-ésimo número de Catalan.

numeroTriangulaciones4 :: Integer -> Integer

numeroTriangulaciones4 n = numeroCatalan (n-2)

numeroCatalan :: Integer -> Integer

numeroCatalan n =

factorial (2*n) `div` (factorial (n+1) * factorial n)

factorial :: Integer -> Integer

factorial n = product [1..n]

-- 5ª solución

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

numeroTriangulaciones5 :: Integer -> Integer

numeroTriangulaciones5 n = v V.! (m-2)

where v = V.constructN m

(\w -> if V.null w then 1

else V.sum (V.zipWith (*) w (V.reverse w)))

m = fromIntegral n

-- 6ª solución

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

numeroTriangulaciones6 :: Integer -> Integer

numeroTriangulaciones6 n = nCr (2*n-4, n-2) `div` (n-1)

where nCr (n,m) = factorial n `div` (factorial (n-m) * factorial m)

factorial n = product [1..n]

-- Comparación de eficiencia

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

-- λ> numeroTriangulaciones 22

-- 6564120420

-- (3.97 secs, 668,070,936 bytes)

-- λ> numeroTriangulaciones2 22

-- 6564120420

-- (0.01 secs, 180,064 bytes)

-- λ> numeroTriangulaciones3 22

-- 6564120420

-- (0.01 secs, 285,792 bytes)

-- λ> length (show (numeroTriangulaciones2 800))

-- 476

-- (0.59 secs, 125,026,824 bytes)

-- λ> length (show (numeroTriangulaciones3 800))

-- 476

-- (1.95 secs, 334,652,936 bytes)

-- λ> length (show (numeroTriangulaciones4 800))

-- 476

-- (0.01 secs, 2,960,088 bytes)

-- λ> length (show (numeroTriangulaciones5 800))

-- 476

-- (0.65 secs, 200,415,640 bytes)

-- λ> length (show (numeroTriangulaciones6 800))

-- 476

-- (0.01 secs, 2,960,224 bytes)

-- λ> length (show (numeroTriangulaciones4 (10^4)))

-- 6014

-- (1.80 secs, 542,364,320 bytes)

-- λ> length (show (numeroTriangulaciones6 (10^4)))

-- 6014

-- (1.87 secs, 542,351,136 bytes)

Sucesiones suaves

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

Una sucesión es suave si valor absoluto de la diferencia de sus términos consecutivos es 1.

Definir la función

   suaves :: Int -> [[Int]]

1	suaves :: Int -> [[Int]]

tal que (suaves n) es la lista de las sucesiones suaves de longitud n cuyo último término es 0. Por ejemplo,

   suaves 2  ==  [[1,0],[-1,0]]
   suaves 3  ==  [[2,1,0],[0,1,0],[0,-1,0],[-2,-1,0]]

1 2	suaves 2 == [[1,0],[-1,0]] suaves 3 == [[2,1,0],[0,1,0],[0,-1,0],[-2,-1,0]]

Soluciones

suaves :: Int -> [[Int]]
suaves 0 = []
suaves 1 = [[0]]
suaves n = concat [[x+1:x:xs,x-1:x:xs] | (x:xs) <- suaves (n-1)]

suaves :: Int -> [[Int]]

suaves 0 = []

suaves 1 = [[0]]

suaves n = concat [[x+1:x:xs,x-1:x:xs] | (x:xs) <- suaves (n-1)]

Clausura respecto de una operación binaria

PorJosé A. Alonso 2-mayo-20189-mayo-2018

Se dice que una operador @ es interno en un conjunto A si al @ sobre elementos de A se obtiene como resultado otro elemento de A. Por ejemplo, la suma es un operador interno en el conjunto de los números naturales pares.

La clausura de un conjunto A con respecto a un operador @ es el menor conjunto B tal que A está contenido en B y el operador @ es interno en el conjunto B. Por ejemplo, la clausura del conjunto {2} con respecto a la suma es el conjunto de los números pares positivos:

   {2, 4, 6, 8, ...} = {2*k | k <- [1..]}

1	{2, 4, 6, 8, ...} = {2*k \| k <- [1..]}

Definir la función

   clausuraOperador :: (Int -> Int -> Int) -> Set Int -> Set Int

1	clausuraOperador :: (Int -> Int -> Int) -> Set Int -> Set Int

tal que (clausuraOperador op xs) es la clausura del conjunto xs con respecto a la operación op. Por ejemplo,

   clausuraOperador gcd (fromList [6,9,10])     ==
      fromList [1,2,3,6,9,10]
   clausuraOperador gcd (fromList [42,70,105])  ==
      fromList [7,14,21,35,42,70,105]
   clausuraOperador lcm (fromList [6,9,10])     ==
      fromList [6,9,10,18,30,90]
   clausuraOperador lcm (fromList [2,3,5,7])    ==
      fromList [2,3,5,6,7,10,14,15,21,30,35,42,70,105,210]

clausuraOperador gcd (fromList [6,9,10]) ==

fromList [1,2,3,6,9,10]

clausuraOperador gcd (fromList [42,70,105]) ==

fromList [7,14,21,35,42,70,105]

clausuraOperador lcm (fromList [6,9,10]) ==

fromList [6,9,10,18,30,90]

clausuraOperador lcm (fromList [2,3,5,7]) ==

fromList [2,3,5,6,7,10,14,15,21,30,35,42,70,105,210]

Soluciones

import Prelude hiding (map)
import Data.Set ( Set
                , elems
                , fromList
                , map
                , notMember
                , union
                , unions
                ) 

-- 1ª definición 
clausuraOperador :: (Int -> Int -> Int) -> Set Int -> Set Int
clausuraOperador op =
  until (\ xs -> null [(x,y) | x <- elems xs,
                               y <- elems xs,
                               notMember (op x y) xs])
        (\ xs -> union xs (fromList [op x y | x <- elems xs,
                                              y <- elems xs]))

-- 2ª definición 
clausuraOperador2 :: (Int -> Int -> Int) -> Set Int -> Set Int
clausuraOperador2 op = until ((==) <*> g) g
  where g ys = unions [map (`op` y) ys | y <- elems ys]

import Prelude hiding (map)

import Data.Set ( Set

, elems

, fromList

, map

, notMember

, union

, unions

)

-- 1ª definición

clausuraOperador :: (Int -> Int -> Int) -> Set Int -> Set Int

clausuraOperador op =

until (\ xs -> null [(x,y) | x <- elems xs,

y <- elems xs,

notMember (op x y) xs])

(\ xs -> union xs (fromList [op x y | x <- elems xs,

y <- elems xs]))

-- 2ª definición

clausuraOperador2 :: (Int -> Int -> Int) -> Set Int -> Set Int

clausuraOperador2 op = until ((==) <*> g) g

where g ys = unions [map (`op` y) ys | y <- elems ys]

Subconjuntos con suma dada

PorJosé A. Alonso 25-abril-20182-mayo-2018

Sea S un conjunto finito de números enteros positivos y n un número natural. El problema consiste en calcular los subconjuntos de S cuya suma es n.

Definir la función

   subconjuntosSuma:: [Int] -> Int -> [[Int]] tal que

1	subconjuntosSuma:: [Int] -> Int -> [[Int]] tal que

tal que (subconjuntosSuma xs n) es la lista de los subconjuntos de xs cuya suma es n. Por ejemplo,

   λ> subconjuntosSuma [3,34,4,12,5,2] 9
   [[4,5],[3,4,2]]
   λ> subconjuntosSuma [3,34,4,12,5,2] 13
   []
   λ> length (subconjuntosSuma [1..100] (sum [1..100]))
   1

λ> subconjuntosSuma [3,34,4,12,5,2] 9

[[4,5],[3,4,2]]

λ> subconjuntosSuma [3,34,4,12,5,2] 13

[]

λ> length (subconjuntosSuma [1..100] (sum [1..100]))

Soluciones

import Data.Array
import qualified Data.Matrix as M
import Data.Maybe
import Data.List
import Test.QuickCheck

-- 1ª definición (Calculando todos los subconjuntos)
-- =================================================

subconjuntosSuma1 :: [Int] -> Int -> [[Int]]
subconjuntosSuma1 xs n =
  [ys | ys <- subsequences xs, sum ys == n]

-- 2ª definición (por recursión)
-- =============================

subconjuntosSuma2 :: [Int] -> Int -> [[Int]]
subconjuntosSuma2 _  0 = [[]]
subconjuntosSuma2 [] _ = []
subconjuntosSuma2 (x:xs) n
  | n < x     = subconjuntosSuma2 xs n
  | otherwise = subconjuntosSuma2 xs n ++
                [x:ys | ys <- subconjuntosSuma2 xs (n-x)]

-- 3ª definición (por programación dinámica)
-- =========================================

subconjuntosSuma3 :: [Int] -> Int -> [[Int]]
subconjuntosSuma3 xs n =
  map reverse (matrizSubconjuntosSuma3 xs n ! (length xs,n))

-- (matrizSubconjuntosSuma3 xs m) es la matriz q tal que q(i,j) es la
-- lista de los subconjuntos de (take i xs) que suman j. Por ejemplo,
--    λ> elems (matrizSubconjuntosSuma3 [1,3,5] 9)
--    [[[]],[],   [],[],   [],     [],   [],     [],[],    [],
--     [[]],[[1]],[],[],   [],     [],   [],     [],[],    [],
--     [[]],[[1]],[],[[3]],[[3,1]],[],   [],     [],[],    [],
--     [[]],[[1]],[],[[3]],[[3,1]],[[5]],[[5,1]],[],[[5,3]],[[5,3,1]]]
-- Con las cabeceras,
--            0    1     2  3     4       5     6       7  8       9 
--    []     [[[]],[],   [],[],   [],     [],   [],     [],[],    [],
--    [1]     [[]],[[1]],[],[],   [],     [],   [],     [],[],    [],
--    [1,3]   [[]],[[1]],[],[[3]],[[3,1]],[],   [],     [],[],    [],
--    [1,3,5] [[]],[[1]],[],[[3]],[[3,1]],[[5]],[[5,1]],[],[[5,3]],[[5,3,1]]]
matrizSubconjuntosSuma3 :: [Int] -> Int -> Array (Int,Int) [[Int]]
matrizSubconjuntosSuma3 xs n = q
  where m = length xs
        v = listArray (1,m) xs
        q = array ((0,0),(m,n)) [((i,j), f i j) | i <- [0..m],
                                                  j <- [0..n]]
        f _ 0 = [[]]
        f 0 _ = []
        f i j | j < v ! i = q ! (i-1,j)
              | otherwise = q ! (i-1,j) ++
                            [v!i:ys | ys <- q ! (i-1,j-v!i)]

-- 4ª definición (ordenando y por recursión)
-- =========================================

subconjuntosSuma4 :: [Int] -> Int -> [[Int]]
subconjuntosSuma4 xs = aux (sort xs)
  where aux _  0 = [[]]
        aux [] _ = []
        aux (y:ys) n
          | y > n     = []
          | otherwise = aux ys n ++ [y:zs | zs <- aux ys (n-y)]

-- 5ª definición (ordenando y dinámica)
-- ====================================

subconjuntosSuma5 :: [Int] -> Int -> [[Int]]
subconjuntosSuma5 xs n =
  matrizSubconjuntosSuma5 (reverse (sort xs)) n ! (length xs,n)

matrizSubconjuntosSuma5 :: [Int] -> Int -> Array (Int,Int) [[Int]]
matrizSubconjuntosSuma5 xs n = q
  where m = length xs
        v = listArray (1,m) xs
        q = array ((0,0),(m,n)) [((i,j), f i j) | i <- [0..m],
                                                  j <- [0..n]]
        f _ 0 = [[]]
        f 0 _ = []
        f i j | v ! i > j = []
              | otherwise = q ! (i-1,j) ++
                            [v!i:ys | ys <- q ! (i-1,j-v!i)]

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

prop_subconjuntosSuma :: [Int] -> Int -> Bool
prop_subconjuntosSuma xs n =
  all (`igual` subconjuntosSuma2 ys m) [ subconjuntosSuma3 ys m
                                       , subconjuntosSuma4 ys m
                                       , subconjuntosSuma5 ys m ]
  where ys = map (\y -> 1 + abs y) xs 
        m  = abs n
        ordenado = sort . map sort
        igual xss yss = ordenado xss == ordenado yss

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

100

101

102

import Data.Array

import qualified Data.Matrix as M

import Data.Maybe

import Data.List

import Test.QuickCheck

-- 1ª definición (Calculando todos los subconjuntos)

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

subconjuntosSuma1 :: [Int] -> Int -> [[Int]]

subconjuntosSuma1 xs n =

[ys | ys <- subsequences xs, sum ys == n]

-- 2ª definición (por recursión)

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

subconjuntosSuma2 :: [Int] -> Int -> [[Int]]

subconjuntosSuma2 _ 0 = [[]]

subconjuntosSuma2 [] _ = []

subconjuntosSuma2 (x:xs) n

| n < x = subconjuntosSuma2 xs n

| otherwise = subconjuntosSuma2 xs n ++

[x:ys | ys <- subconjuntosSuma2 xs (n-x)]

-- 3ª definición (por programación dinámica)

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

subconjuntosSuma3 :: [Int] -> Int -> [[Int]]

subconjuntosSuma3 xs n =

map reverse (matrizSubconjuntosSuma3 xs n ! (length xs,n))

-- (matrizSubconjuntosSuma3 xs m) es la matriz q tal que q(i,j) es la

-- lista de los subconjuntos de (take i xs) que suman j. Por ejemplo,

-- λ> elems (matrizSubconjuntosSuma3 [1,3,5] 9)

-- [[[]],[], [],[], [], [], [], [],[], [],

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

-- [[]],[[1]],[],[[3]],[[3,1]],[], [], [],[], [],

-- [[]],[[1]],[],[[3]],[[3,1]],[[5]],[[5,1]],[],[[5,3]],[[5,3,1]]]

-- Con las cabeceras,

-- 0 1 2 3 4 5 6 7 8 9

-- [] [[[]],[], [],[], [], [], [], [],[], [],

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

-- [1,3] [[]],[[1]],[],[[3]],[[3,1]],[], [], [],[], [],

-- [1,3,5] [[]],[[1]],[],[[3]],[[3,1]],[[5]],[[5,1]],[],[[5,3]],[[5,3,1]]]

matrizSubconjuntosSuma3 :: [Int] -> Int -> Array (Int,Int) [[Int]]

matrizSubconjuntosSuma3 xs n = q

where m = length xs

v = listArray (1,m) xs

q = array ((0,0),(m,n)) [((i,j), f i j) | i <- [0..m],

j <- [0..n]]

f _ 0 = [[]]

f 0 _ = []

f i j | j < v ! i = q ! (i-1,j)

| otherwise = q ! (i-1,j) ++

[v!i:ys | ys <- q ! (i-1,j-v!i)]

-- 4ª definición (ordenando y por recursión)

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

subconjuntosSuma4 :: [Int] -> Int -> [[Int]]

subconjuntosSuma4 xs = aux (sort xs)

where aux _ 0 = [[]]

aux [] _ = []

aux (y:ys) n

| y > n = []

| otherwise = aux ys n ++ [y:zs | zs <- aux ys (n-y)]

-- 5ª definición (ordenando y dinámica)

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

subconjuntosSuma5 :: [Int] -> Int -> [[Int]]

subconjuntosSuma5 xs n =

matrizSubconjuntosSuma5 (reverse (sort xs)) n ! (length xs,n)

matrizSubconjuntosSuma5 :: [Int] -> Int -> Array (Int,Int) [[Int]]

matrizSubconjuntosSuma5 xs n = q

where m = length xs

v = listArray (1,m) xs

q = array ((0,0),(m,n)) [((i,j), f i j) | i <- [0..m],

j <- [0..n]]

f _ 0 = [[]]

f 0 _ = []

f i j | v ! i > j = []

| otherwise = q ! (i-1,j) ++

[v!i:ys | ys <- q ! (i-1,j-v!i)]

-- Equivalencia

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

prop_subconjuntosSuma :: [Int] -> Int -> Bool

prop_subconjuntosSuma xs n =

all (`igual` subconjuntosSuma2 ys m) [ subconjuntosSuma3 ys m

, subconjuntosSuma4 ys m

, subconjuntosSuma5 ys m ]

where ys = map (\y -> 1 + abs y) xs

m = abs n

ordenado = sort . map sort

igual xss yss = ordenado xss == ordenado yss

-- La comprobación es

-- λ> quickCheck prop_subconjuntosSuma

-- +++ OK, passed 100 tests.

Subsucesiones crecientes de elementos consecutivos

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

Definir la función

   subsucesiones :: [Integer] -> [[Integer]]

1	subsucesiones :: [Integer] -> [[Integer]]

tal que (subsucesiones xs) es la lista de las subsucesiones crecientes de elementos consecutivos de xs. Por ejemplo,

   subsucesiones [1,0,1,2,3,0,4,5]  == [[1],[0,1,2,3],[0,4,5]]
   subsucesiones [5,6,1,3,2,7]      == [[5,6],[1,3],[2,7]]
   subsucesiones [2,3,3,4,5]        == [[2,3],[3,4,5]]
   subsucesiones [7,6,5,4]          == [[7],[6],[5],[4]]

subsucesiones [1,0,1,2,3,0,4,5] == [[1],[0,1,2,3],[0,4,5]]

subsucesiones [5,6,1,3,2,7] == [[5,6],[1,3],[2,7]]

subsucesiones [2,3,3,4,5] == [[2,3],[3,4,5]]

subsucesiones [7,6,5,4] == [[7],[6],[5],[4]]

Soluciones

subsucesiones :: [Integer] -> [[Integer]]
subsucesiones []  = []
subsucesiones [x] = [[x]]
subsucesiones (x:y:zs)
  | x < y     = (x:us):vss
  | otherwise = [x]:p
  where p@(us:vss) = subsucesiones (y:zs)

subsucesiones :: [Integer] -> [[Integer]]

subsucesiones [] = []

subsucesiones [x] = [[x]]

subsucesiones (x:y:zs)

| x < y = (x:us):vss

| otherwise = [x]:p

where p@(us:vss) = subsucesiones (y:zs)

Matrices de Hadamard

PorJosé A. Alonso 17-abril-201825-abril-2021

Las matrices de Hadamard se definen recursivamente como sigue

   λ> hadamard 0
   ( 1 )
   
   λ> hadamard 1
   (  1  1 )
   (  1 -1 )
   
   λ> hadamard 2
   (  1  1  1  1 )
   (  1 -1  1 -1 )
   (  1  1 -1 -1 )
   (  1 -1 -1  1 )
   
   λ> hadamard 3
   (  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 -1  1 -1  1 )
   (  1  1 -1 -1 -1 -1  1  1 )
   (  1 -1 -1  1 -1  1  1 -1 )

λ> hadamard 0

( 1 )

λ> hadamard 1

( 1 1 )

( 1 -1 )

λ> hadamard 2

( 1 1 1 1 )

( 1 -1 1 -1 )

( 1 1 -1 -1 )

( 1 -1 -1 1 )

λ> hadamard 3

( 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 -1 1 -1 1 )

( 1 1 -1 -1 -1 -1 1 1 )

( 1 -1 -1 1 -1 1 1 -1 )

En general, la n-ésima matriz de Hadamard, H(n), es

   ( H(n-1)  H(n-1) )
   ( H(n-1) -H(n-1) )

1 2	( H(n-1) H(n-1) ) ( H(n-1) -H(n-1) )

Definir la función

   hadamard :: Int -> Matrix Int

1	hadamard :: Int -> Matrix Int

tal que (hadamard n) es la n-ésima matriz de Hadamard.

Comprobar con QuickCheck que para todo número natural n, el producto de la n-ésima matriz de Hadamard y su traspuesta es igual al producto de 2^n por la matriz identidad de orden 2^n.

Soluciones

import Data.Matrix (Matrix, identity, joinBlocks, scaleMatrix, transpose)
import Test.QuickCheck 

hadamard :: Int -> Matrix Int
hadamard 0 = identity 1
hadamard n = joinBlocks (a, a, a, b)
  where a = hadamard (n-1)
        b = scaleMatrix (-1) a

-- La propiedad es
prop_Hadamard :: (Positive Int) -> Bool
prop_Hadamard (Positive n) =
  h * transpose h == scaleMatrix (2^n) (identity (2^n))
  where h = hadamard n

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

import Data.Matrix (Matrix, identity, joinBlocks, scaleMatrix, transpose)

import Test.QuickCheck

hadamard :: Int -> Matrix Int

hadamard 0 = identity 1

hadamard n = joinBlocks (a, a, a, b)

where a = hadamard (n-1)

b = scaleMatrix (-1) a

-- La propiedad es

prop_Hadamard :: (Positive Int) -> Bool

prop_Hadamard (Positive n) =

h * transpose h == scaleMatrix (2^n) (identity (2^n))

where h = hadamard n

-- La comprobación es

-- λ> quickCheckWith (stdArgs {maxSize=7}) prop_Hadamard

-- +++ OK, passed 100 tests.

Decidir si existe un subconjunto con suma dada

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

Sea S un conjunto finito de números naturales y m un número natural. El problema consiste en determinar si existe un subconjunto de S cuya suma es m. Por ejemplo, si S = [3,34,4,12,5,2] y m = 9, existe un subconjunto de S, [4,5], cuya suma es 9. En cambio, no hay ningún subconjunto de S que sume 13.

Definir la función

    existeSubSuma :: [Int] -> Int -> Bool

1	existeSubSuma :: [Int] -> Int -> Bool

tal que (existeSubSuma xs m) se verifica si existe algún subconjunto de xs que sume m. Por ejemplo,

    existeSubSuma [3,34,4,12,5,2] 9                == True
    existeSubSuma [3,34,4,12,5,2] 13               == False
    existeSubSuma ([3,34,4,12,5,2]++[20..400]) 13  == False
    existeSubSuma ([3,34,4,12,5,2]++[20..400]) 654 == True
    existeSubSuma [1..200] (sum [1..200])          == True

existeSubSuma [3,34,4,12,5,2] 9 == True

existeSubSuma [3,34,4,12,5,2] 13 == False

existeSubSuma ([3,34,4,12,5,2]++[20..400]) 13 == False

existeSubSuma ([3,34,4,12,5,2]++[20..400]) 654 == True

existeSubSuma [1..200] (sum [1..200]) == True

Soluciones

import Data.List  (subsequences, sort)
import Data.Array (Array, array, listArray, (!))
 
-- 1ª definición (Calculando todos los subconjuntos)
-- =================================================
 
existeSubSuma1 :: [Int] -> Int -> Bool
existeSubSuma1 xs n =
  any (\ys -> sum ys == n) (subsequences xs)
 
-- 2ª definición (por recursión)
-- =============================
 
existeSubSuma2 :: [Int] -> Int -> Bool
existeSubSuma2 _  0 = True
existeSubSuma2 [] _ = False
existeSubSuma2 (x:xs) n
  | n < x     = existeSubSuma2 xs n
  | otherwise = existeSubSuma2 xs (n-x) || existeSubSuma2 xs n 
  
-- 3ª definición (por programación dinámica)
-- =========================================
 
existeSubSuma3 :: [Int] -> Int -> Bool
existeSubSuma3 xs n =
  matrizExisteSubSuma3 xs n ! (length xs,n) 
 
-- (matrizExisteSubSuma3 xs m) es la matriz q tal que q(i,j) se verifica
-- si existe algún subconjunto de (take i xs) que sume j. Por ejemplo,
--    λ> elems (matrizExisteSubSuma3 [1,3,5] 9)
--    [True,False,False,False,False,False,False,False,False,False,
--     True,True, False,False,False,False,False,False,False,False,
--     True,True, False,True, True, False,False,False,False,False,
--     True,True, False,True, True, True, True, False,True, True]
-- Con las cabeceras,
--            0     1     2     3     4     5     6     7     8     9
--    []     [True,False,False,False,False,False,False,False,False,False,
--    [1]     True,True, False,False,False,False,False,False,False,False,
--    [1,3]   True,True, False,True, True, False,False,False,False,False,
--    [1,3,5] True,True, False,True, True, True, True, False,True, True]
matrizExisteSubSuma3 :: [Int] -> Int -> Array (Int,Int) Bool
matrizExisteSubSuma3 xs n = q
  where m = length xs
        v = listArray (1,m) xs
        q = array ((0,0),(m,n)) [((i,j), f i j) | i <- [0..m],
                                                  j <- [0..n]]
        f _ 0 = True
        f 0 _ = False
        f i j | j < v ! i = q ! (i-1,j)
              | otherwise = q ! (i-1,j-v!i) || q ! (i-1,j)
 
-- 4ª definición (ordenando y por recursión)
-- =========================================
 
existeSubSuma4 :: [Int] -> Int -> Bool
existeSubSuma4 xs = aux (sort xs)
  where aux _  0 = True
        aux [] _ = False
        aux (y:ys) n
          | y <= n    = aux ys (n-y) || aux ys n
          | otherwise = False
 
-- 5ª definición (ordenando y dinámica)
-- ====================================
 
existeSubSuma5 :: [Int] -> Int -> Bool
existeSubSuma5 xs n =
  matrizExisteSubSuma5 (reverse (sort xs)) n ! (length xs,n) 
 
matrizExisteSubSuma5 :: [Int] -> Int -> Array (Int,Int) Bool
matrizExisteSubSuma5 xs n = q
  where m = length xs
        v = listArray (1,m) xs
        q = array ((0,0),(m,n)) [((i,j), f i j) | i <- [0..m],
                                                  j <- [0..n]]
        f _ 0 = True
        f 0 _ = False
        f i j | v ! i <= j = q ! (i-1,j-v!i) || q ! (i-1,j) 
              | otherwise  = False
 
-- Equivalencia
-- ============
 
prop_existeSubSuma :: [Int] -> Int -> Bool
prop_existeSubSuma xs n =
  all (== existeSubSuma2 ys m) [ existeSubSuma3 ys m
                               , existeSubSuma4 ys m
                               , existeSubSuma5 ys m ]
  where ys = map abs xs
        m  = abs n
 
-- La comprobación es
--    λ> quickCheck prop_existeSubSuma
--    +++ OK, passed 100 tests.
 
-- Comparación de eficiencia:
-- ==========================

--    λ> let xs = [1..22] in existeSubSuma1 xs (sum xs)
--    True
--    (7.76 secs, 3,892,403,928 bytes)
--    λ> let xs = [1..22] in existeSubSuma2 xs (sum xs)
--    True
--    (0.02 secs, 95,968 bytes)
--    λ> let xs = [1..22] in existeSubSuma3 xs (sum xs)
--    True
--    (0.03 secs, 6,055,200 bytes)
--    λ> let xs = [1..22] in existeSubSuma4 xs (sum xs)
--    True
--    (0.01 secs, 98,880 bytes)
--    λ> let xs = [1..22] in existeSubSuma5 xs (sum xs)
--    True
--    (0.02 secs, 2,827,560 bytes)
  
--    λ> let xs = [1..200] in existeSubSuma2 xs (sum xs)
--    True
--    (0.01 secs, 182,280 bytes)
--    λ> let xs = [1..200] in existeSubSuma3 xs (sum xs)
--    True
--    (8.89 secs, 1,875,071,968 bytes)
--    λ> let xs = [1..200] in existeSubSuma4 xs (sum xs)
--    True
--    (0.02 secs, 217,128 bytes)
--    λ> let xs = [1..200] in existeSubSuma5 xs (sum xs)
--    True
--    (8.66 secs, 1,875,087,976 bytes)
--
--    λ> and [existeSubSuma2 [1..20] n | n <- [1..sum [1..20]]]
--    True
--    (2.82 secs, 323,372,512 bytes)
--    λ> and [existeSubSuma3 [1..20] n | n <- [1..sum [1..20]]]
--    True
--    (0.65 secs, 221,806,376 bytes)
--    λ> and [existeSubSuma4 [1..20] n | n <- [1..sum [1..20]]]
--    True
--    (4.12 secs, 535,153,152 bytes)
--    λ> and [existeSubSuma5 [1..20] n | n <- [1..sum [1..20]]]
--    True
--    (0.73 secs, 238,579,696 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

import Data.List (subsequences, sort)

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

-- 1ª definición (Calculando todos los subconjuntos)

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

existeSubSuma1 :: [Int] -> Int -> Bool

existeSubSuma1 xs n =

any (\ys -> sum ys == n) (subsequences xs)

-- 2ª definición (por recursión)

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

existeSubSuma2 :: [Int] -> Int -> Bool

existeSubSuma2 _ 0 = True

existeSubSuma2 [] _ = False

existeSubSuma2 (x:xs) n

| n < x = existeSubSuma2 xs n

| otherwise = existeSubSuma2 xs (n-x) || existeSubSuma2 xs n

-- 3ª definición (por programación dinámica)

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

existeSubSuma3 :: [Int] -> Int -> Bool

existeSubSuma3 xs n =

matrizExisteSubSuma3 xs n ! (length xs,n)

-- (matrizExisteSubSuma3 xs m) es la matriz q tal que q(i,j) se verifica

-- si existe algún subconjunto de (take i xs) que sume j. Por ejemplo,

-- λ> elems (matrizExisteSubSuma3 [1,3,5] 9)

-- [True,False,False,False,False,False,False,False,False,False,

-- True,True, False,False,False,False,False,False,False,False,

-- True,True, False,True, True, False,False,False,False,False,

-- True,True, False,True, True, True, True, False,True, True]

-- Con las cabeceras,

-- 0 1 2 3 4 5 6 7 8 9

-- [] [True,False,False,False,False,False,False,False,False,False,

-- [1] True,True, False,False,False,False,False,False,False,False,

-- [1,3] True,True, False,True, True, False,False,False,False,False,

-- [1,3,5] True,True, False,True, True, True, True, False,True, True]

matrizExisteSubSuma3 :: [Int] -> Int -> Array (Int,Int) Bool

matrizExisteSubSuma3 xs n = q

where m = length xs

v = listArray (1,m) xs

q = array ((0,0),(m,n)) [((i,j), f i j) | i <- [0..m],

j <- [0..n]]

f _ 0 = True

f 0 _ = False

f i j | j < v ! i = q ! (i-1,j)

| otherwise = q ! (i-1,j-v!i) || q ! (i-1,j)

-- 4ª definición (ordenando y por recursión)

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

existeSubSuma4 :: [Int] -> Int -> Bool

existeSubSuma4 xs = aux (sort xs)

where aux _ 0 = True

aux [] _ = False

aux (y:ys) n

| y <= n = aux ys (n-y) || aux ys n

| otherwise = False

-- 5ª definición (ordenando y dinámica)

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

existeSubSuma5 :: [Int] -> Int -> Bool

existeSubSuma5 xs n =

matrizExisteSubSuma5 (reverse (sort xs)) n ! (length xs,n)

matrizExisteSubSuma5 :: [Int] -> Int -> Array (Int,Int) Bool

matrizExisteSubSuma5 xs n = q

where m = length xs

v = listArray (1,m) xs

q = array ((0,0),(m,n)) [((i,j), f i j) | i <- [0..m],

j <- [0..n]]

f _ 0 = True

f 0 _ = False

f i j | v ! i <= j = q ! (i-1,j-v!i) || q ! (i-1,j)

| otherwise = False

-- Equivalencia

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

prop_existeSubSuma :: [Int] -> Int -> Bool

prop_existeSubSuma xs n =

all (== existeSubSuma2 ys m) [ existeSubSuma3 ys m

, existeSubSuma4 ys m

, existeSubSuma5 ys m ]

where ys = map abs xs

m = abs n

-- La comprobación es

-- λ> quickCheck prop_existeSubSuma

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia:

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

-- λ> let xs = [1..22] in existeSubSuma1 xs (sum xs)

-- True

-- (7.76 secs, 3,892,403,928 bytes)

-- λ> let xs = [1..22] in existeSubSuma2 xs (sum xs)

-- True

-- (0.02 secs, 95,968 bytes)

-- λ> let xs = [1..22] in existeSubSuma3 xs (sum xs)

-- True

-- (0.03 secs, 6,055,200 bytes)

-- λ> let xs = [1..22] in existeSubSuma4 xs (sum xs)

-- True

-- (0.01 secs, 98,880 bytes)

-- λ> let xs = [1..22] in existeSubSuma5 xs (sum xs)

-- True

-- (0.02 secs, 2,827,560 bytes)

-- λ> let xs = [1..200] in existeSubSuma2 xs (sum xs)

-- True

-- (0.01 secs, 182,280 bytes)

-- λ> let xs = [1..200] in existeSubSuma3 xs (sum xs)

-- True

-- (8.89 secs, 1,875,071,968 bytes)

-- λ> let xs = [1..200] in existeSubSuma4 xs (sum xs)

-- True

-- (0.02 secs, 217,128 bytes)

-- λ> let xs = [1..200] in existeSubSuma5 xs (sum xs)

-- True

-- (8.66 secs, 1,875,087,976 bytes)

-- λ> and [existeSubSuma2 [1..20] n | n <- [1..sum [1..20]]]

-- True

-- (2.82 secs, 323,372,512 bytes)

-- λ> and [existeSubSuma3 [1..20] n | n <- [1..sum [1..20]]]

-- True

-- (0.65 secs, 221,806,376 bytes)

-- λ> and [existeSubSuma4 [1..20] n | n <- [1..sum [1..20]]]

-- True

-- (4.12 secs, 535,153,152 bytes)

-- λ> and [existeSubSuma5 [1..20] n | n <- [1..sum [1..20]]]

-- True

-- (0.73 secs, 238,579,696 bytes)

Búsqueda en los dígitos de pi

PorJosé A. Alonso 13-abril-201826-marzo-2022

El fichero Digitos_de_pi.txt contiene el número pi con un millón de decimales; es decir,

   3.1415926535897932384626433832 ... 83996346460422090106105779458151

1	3.1415926535897932384626433832 ... 83996346460422090106105779458151

Definir la función

   posicion :: String -> IO (Maybe Int)

1	posicion :: String -> IO (Maybe Int)

tal que (posicion n) es (Just k) si k es la posición de n en la sucesión formada por un millón dígitos decimales del número pi y Nothing si n no ocurre en dicha sucesión. Por ejemplo,

   λ> posicion "15"
   Just 3
   λ> posicion "2017"
   Just 8897
   λ> posicion "022017"
   Just 382052
   λ> posicion "14022017"
   Nothing
   λ> posicion "999999"
   Just 762
   λ> posicion "458151"
   Just 999995

λ> posicion "15"

Just 3

λ> posicion "2017"

Just 8897

λ> posicion "022017"

Just 382052

λ> posicion "14022017"

Nothing

λ> posicion "999999"

Just 762

λ> posicion "458151"

Just 999995

Nota. Se puede comprobar la función mediante The pi-search page o Pi search engine.

Soluciones

import Data.List (isPrefixOf)

posicion :: String -> IO (Maybe Int)
posicion ns = do
  ds <- readFile "Digitos_de_pi.txt"
  return (posicionEnLista (drop 2 ds) ns)

posicionEnLista :: Eq a => [a] -> [a] -> Maybe Int
posicionEnLista xs ys = aux xs 1
  where aux [] _ = Nothing
        aux (x:xs) n | ys `isPrefixOf` (x:xs) = Just n
                     | otherwise              = aux xs (n+1)

import Data.List (isPrefixOf)

posicion :: String -> IO (Maybe Int)

posicion ns = do

ds <- readFile "Digitos_de_pi.txt"

return (posicionEnLista (drop 2 ds) ns)

posicionEnLista :: Eq a => [a] -> [a] -> Maybe Int

posicionEnLista xs ys = aux xs 1

where aux [] _ = Nothing

aux (x:xs) n | ys `isPrefixOf` (x:xs) = Just n

| otherwise = aux xs (n+1)

Clases de equivalencia

PorJosé A. Alonso 5-abril-201812-abril-2018

Definir la función

   clasesEquivalencia :: Ord a => 
                         Set a -> (a -> a -> Bool) -> Set (Set a)

1 2	clasesEquivalencia :: Ord a => Set a -> (a -> a -> Bool) -> Set (Set a)

tal que (clasesEquivalencia xs r) es el conjunto de las clases de equivalencia de xs respecto de la relación de equivalencia r. Por ejemplo,

   ghci> let c = fromList [-3..3]
   ghci> clasesEquivalencia c (\x y -> x `mod` 3 == y `mod` 3)
   fromList [fromList [-3,0,3],fromList [-2,1],fromList [-1,2]]
   ghci> clasesEquivalencia c (\x y -> (x - y) `mod` 2 == 0)
   fromList [fromList [-3,-1,1,3],fromList [-2,0,2]]

ghci> let c = fromList [-3..3]

ghci> clasesEquivalencia c (\x y -> x `mod` 3 == y `mod` 3)

fromList [fromList [-3,0,3],fromList [-2,1],fromList [-1,2]]

ghci> clasesEquivalencia c (\x y -> (x - y) `mod` 2 == 0)

fromList [fromList [-3,-1,1,3],fromList [-2,0,2]]

Soluciones

import Data.Set as S

clasesEquivalencia :: Ord a => 
                      Set a -> (a -> a -> Bool) -> Set (Set a)
clasesEquivalencia xs r 
    | S.null xs =  empty
    | otherwise =  us `insert` clasesEquivalencia vs r
    where (y,ys)  = deleteFindMin xs
          (us,vs) = partition (r y) xs

import Data.Set as S

clasesEquivalencia :: Ord a =>

Set a -> (a -> a -> Bool) -> Set (Set a)

clasesEquivalencia xs r

| S.null xs = empty

| otherwise = us `insert` clasesEquivalencia vs r

where (y,ys) = deleteFindMin xs

(us,vs) = partition (r y) xs

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]

Mayor número obtenido intercambiando dos dígitos

PorJosé A. Alonso 3-abril-201810-abril-2018

Definir la función

   maximoIntercambio :: Int -> Int

1	maximoIntercambio :: Int -> Int

tal que (maximoIntercambio x) es el máximo número que se puede obtener intercambiando dos dígitos de x. Por ejemplo,

   maximoIntercambio 983562  ==  986532
   maximoIntercambio 31524   ==  51324
   maximoIntercambio 897     ==  987

maximoIntercambio 983562 == 986532

maximoIntercambio 31524 == 51324

maximoIntercambio 897 == 987

Soluciones

import Data.Array

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

maximoIntercambio :: Int -> Int
maximoIntercambio = maximum . intercambios

-- (intercambios x) es la lista de los números obtenidos intercambiando
-- dos dígitos de x. Por ejemplo,
--    intercambios 1234  ==  [2134,3214,4231,1324,1432,1243]
intercambios :: Int -> [Int]
intercambios x = [intercambio i j x | i <- [0..n-2], j <- [i+1..n-1]]
    where n = length (show x)

-- (intercambio i j x) es el número obtenido intercambiando las cifras
-- que ocupan las posiciones i y j (empezando a contar en cero) del
-- número x. Por ejemplo,
--    intercambio 2 5 123456789  ==  126453789
intercambio :: Int -> Int -> Int -> Int
intercambio i j x = read (concat [as,[d],cs,[b],ds])
    where xs        = show x
          (as,b:bs) = splitAt i xs 
          (cs,d:ds) = splitAt (j-i-1) bs

-- 2ª solución (con vectores)
-- ==========================

maximoIntercambio2 :: Int -> Int
maximoIntercambio2 = read . elems . maximum . intercambios2

-- (intercambios2 x) es la lista de los vectores obtenidos
-- intercambiando dos elementos del vector de dígitos de x. Por ejemplo, 
--    ghci> intercambios2 1234
--    [array (0,3) [(0,'2'),(1,'1'),(2,'3'),(3,'4')],
--     array (0,3) [(0,'3'),(1,'2'),(2,'1'),(3,'4')],
--     array (0,3) [(0,'4'),(1,'2'),(2,'3'),(3,'1')],
--     array (0,3) [(0,'1'),(1,'3'),(2,'2'),(3,'4')],
--     array (0,3) [(0,'1'),(1,'4'),(2,'3'),(3,'2')],
--     array (0,3) [(0,'1'),(1,'2'),(2,'4'),(3,'3')]]
intercambios2 :: Int -> [Array Int Char]
intercambios2 x = [intercambioV i j v | i <- [0..n-2], j <- [i+1..n-1]]
    where xs = show x
          n  = length xs
          v  = listArray (0,n-1) xs

-- (intercambioV i j v) es el vector obtenido intercambiando los
-- elementos de v que ocupan las posiciones i y j. Por ejemplo,
--    ghci> intercambioV 2 4 (listArray (0,4) [3..8])
--    array (0,4) [(0,3),(1,4),(2,7),(3,6),(4,5)]
intercambioV :: Int -> Int -> Array Int a -> Array Int a
intercambioV i j v = v // [(i,v!j),(j,v!i)]

import Data.Array

-- 1ª solución

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

maximoIntercambio :: Int -> Int

maximoIntercambio = maximum . intercambios

-- (intercambios x) es la lista de los números obtenidos intercambiando

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

-- intercambios 1234 == [2134,3214,4231,1324,1432,1243]

intercambios :: Int -> [Int]

intercambios x = [intercambio i j x | i <- [0..n-2], j <- [i+1..n-1]]

where n = length (show x)

-- (intercambio i j x) es el número obtenido intercambiando las cifras

-- que ocupan las posiciones i y j (empezando a contar en cero) del

-- número x. Por ejemplo,

-- intercambio 2 5 123456789 == 126453789

intercambio :: Int -> Int -> Int -> Int

intercambio i j x = read (concat [as,[d],cs,[b],ds])

where xs = show x

(as,b:bs) = splitAt i xs

(cs,d:ds) = splitAt (j-i-1) bs

-- 2ª solución (con vectores)

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

maximoIntercambio2 :: Int -> Int

maximoIntercambio2 = read . elems . maximum . intercambios2

-- (intercambios2 x) es la lista de los vectores obtenidos

-- intercambiando dos elementos del vector de dígitos de x. Por ejemplo,

-- ghci> intercambios2 1234

-- [array (0,3) [(0,'2'),(1,'1'),(2,'3'),(3,'4')],

-- array (0,3) [(0,'3'),(1,'2'),(2,'1'),(3,'4')],

-- array (0,3) [(0,'4'),(1,'2'),(2,'3'),(3,'1')],

-- array (0,3) [(0,'1'),(1,'3'),(2,'2'),(3,'4')],

-- array (0,3) [(0,'1'),(1,'4'),(2,'3'),(3,'2')],

-- array (0,3) [(0,'1'),(1,'2'),(2,'4'),(3,'3')]]

intercambios2 :: Int -> [Array Int Char]

intercambios2 x = [intercambioV i j v | i <- [0..n-2], j <- [i+1..n-1]]

where xs = show x

n = length xs

v = listArray (0,n-1) xs

-- (intercambioV i j v) es el vector obtenido intercambiando los

-- elementos de v que ocupan las posiciones i y j. Por ejemplo,

-- ghci> intercambioV 2 4 (listArray (0,4) [3..8])

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

intercambioV :: Int -> Int -> Array Int a -> Array Int a

intercambioV i j v = v // [(i,v!j),(j,v!i)]

Soluciones

Referencia

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Referencia

Pensamiento

Soluciones

Pensamiento

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Entradas recientes

Buscar

Correo electrónico