Data.List

Máxima suma de caminos en un triángulo

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

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

7 4

2 4 6

8 5 9 3

se reperesenta por

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

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

Definir la función

   maximaSuma :: [[Integer]] -> Integer

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

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

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

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

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

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

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

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

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

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

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

Soluciones

import Data.List (tails)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

import Data.List (tails)

-- 1ª solución

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

maximaSuma1 :: [[Integer]] -> Integer

maximaSuma1 xss =

maximum [sum ys | ys <- caminos xss]

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

caminos [] = [[]]

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

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

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

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

-- 2ª solución

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

maximaSuma2 :: [[Integer]] -> Integer

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

-- 3ª solución

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

maximaSuma3 :: [[Integer]] -> Integer

maximaSuma3 = maximum . map sum . caminos

-- 4ª solución

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

maximaSuma4 :: [[Integer]] -> Integer

maximaSuma4 [] = 0

maximaSuma4 [[x]] = x

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

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

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

-- 5ª solución

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

maximaSuma5 :: [[Integer]] -> Integer

maximaSuma5 xss = head (foldr1 g xss)

where

f x y z = x + max y z

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

-- 6ª solución

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

maximaSuma6 :: [[Integer]] -> Integer

maximaSuma6 xss = head (foldr1 aux xss)

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

-- 7ª solución

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

maximaSuma7 :: [[Integer]] -> Integer

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

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

-- 8ª solución

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

maximaSuma8 :: [[Integer]] -> Integer

maximaSuma8 = head . foldr1 aux

where

aux [] _ = []

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

-- Comparación de eficiencia

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

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

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

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

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

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

triangulo :: Integer -> [[Integer]]

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

-- La comparación es

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

-- λ> maximaSuma1 (triangulo 19)

-- 342

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

-- λ> maximaSuma2 (triangulo 19)

-- 342

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

-- λ> maximaSuma3 (triangulo 19)

-- 342

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

-- λ> maximaSuma4 (triangulo 19)

-- 342

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

-- λ> maximaSuma5 (triangulo 19)

-- 342

-- (0.01 secs, 153,272 bytes)

-- λ> maximaSuma6 (triangulo 19)

-- 342

-- (0.01 secs, 161,360 bytes)

-- λ> maximaSuma7 (triangulo 19)

-- 342

-- (0.01 secs, 187,456 bytes)

-- λ> maximaSuma8 (triangulo 19)

-- 342

-- (0.01 secs, 191,160 bytes)

-- λ> maximaSuma4 (triangulo 22)

-- 462

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

-- λ> maximaSuma5 (triangulo 22)

-- 462

-- (0.00 secs, 173,512 bytes)

-- λ> maximaSuma6 (triangulo 22)

-- 462

-- (0.01 secs, 182,904 bytes)

-- λ> maximaSuma7 (triangulo 22)

-- 462

-- (0.01 secs, 216,560 bytes)

-- λ> maximaSuma8 (triangulo 22)

-- 462

-- (0.01 secs, 224,160 bytes)

-- λ> maximaSuma5 (triangulo 3000)

-- 8997000

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

-- λ> maximaSuma6 (triangulo 3000)

-- 8997000

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

-- λ> maximaSuma7 (triangulo 3000)

-- 8997000

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

-- λ> maximaSuma8 (triangulo 3000)

-- 8997000

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

-- λ> maximaSuma7 (triangulo 4000)

-- 15996000

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

El código se encuentra en GitHub.

Mayor órbita de la sucesión de Collatz

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

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

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

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

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

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

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

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

Definir la función

   mayoresGeneradores :: Integer -> [Integer]

1	mayoresGeneradores :: Integer -> [Integer]

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

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

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

Soluciones

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

100

101

102

103

104

import qualified Data.MemoCombinators as Memo (integral)

import Data.List (genericLength, genericTake, maximumBy)

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

-- 1ª solución

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

mayoresGeneradores :: Integer -> [Integer]

mayoresGeneradores n =

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

where ps = genericTake n longitudesOrbitas

m = maximum (map snd ps)

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

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

-- λ> take 10 longitudesOrbitas

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

longitudesOrbitas :: [(Integer, Integer)]

longitudesOrbitas =

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

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

-- ejemplo,

-- siguiente 13 == 40

-- siguiente 40 == 20

siguiente :: Integer -> Integer

siguiente n | even n = n `div` 2

| otherwise = 3*n+1

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

-- 1. Por ejemplo,

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

-- 1ª definición de collatz

collatz1 :: Integer -> [Integer]

collatz1 1 = [1]

collatz1 n = n : collatz1 (siguiente n)

-- 2ª definición de collatz

collatz2 :: Integer -> [Integer]

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

-- Usaremos la 2ª definición de collatz

collatz :: Integer -> [Integer]

collatz = collatz2

-- 2ª solución

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

mayoresGeneradores2 :: Integer -> [Integer]

mayoresGeneradores2 n =

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

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

m = maximum (map snd ps)

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

-- longitudOrbita 13 == 10

longitudOrbita :: Integer -> Integer

longitudOrbita 1 = 1

longitudOrbita x = 1 + longitudOrbita (siguiente x)

-- 3ª solución

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

mayoresGeneradores3 :: Integer -> [Integer]

mayoresGeneradores3 n =

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

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

m = maximum (map snd ps)

longitudOrbita2 :: Integer -> Integer

longitudOrbita2 = Memo.integral longitudOrbita2'

where

longitudOrbita2' 1 = 1

longitudOrbita2' x = 1 + longitudOrbita2 (siguiente x)

-- Equivalencia de definiciones

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

-- La propiedad es

prop_mayoresGeneradores :: (Positive Integer) -> Bool

prop_mayoresGeneradores (Positive n) =

all (== (mayoresGeneradores n))

[mayoresGeneradores2 n,

mayoresGeneradores3 n]

-- La comprobación es

-- λ> quickCheck prop_mayoresGeneradores

-- +++ OK, passed 100 tests.

-- Comprobación de eficiencia

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

-- La comprobación es

-- λ> mayoresGeneradores (10^5)

-- [77031]

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

-- λ> mayoresGeneradores2 (10^5)

-- [77031]

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

-- λ> mayoresGeneradores3 (10^5)

-- [77031]

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

El código se encuentra en GitHub.

Ternas pitagóricas con suma dada

PorJosé A. Alonso 10-febrero-202213-octubre-2022

Una terna pitagórica es una terna de números naturales (a,b,c) tal que a<b<c y a^2+b^2=c^2. Por ejemplo (3,4,5) es una terna pitagórica.

Definir la función

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

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

tal que (ternasPitagoricas x) es la lista de las ternas pitagóricas cuya suma es x. Por ejemplo,

   ternasPitagoricas 12     == [(3,4,5)]
   ternasPitagoricas 60     == [(10,24,26),(15,20,25)]
   ternasPitagoricas (10^6) == [(218750,360000,421250),(200000,375000,425000)]

ternasPitagoricas 12 == [(3,4,5)]

ternasPitagoricas 60 == [(10,24,26),(15,20,25)]

ternasPitagoricas (10^6) == [(218750,360000,421250),(200000,375000,425000)]

Soluciones

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

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

ternasPitagoricas1 :: Integer -> [(Integer,Integer,Integer)]
ternasPitagoricas1 x =
  [(a,b,c) | a <- [0..x],
             b <- [a+1..x],
             c <- [b+1..x],
             a^2 + b^2 == c^2,
             a+b+c == x]

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

ternasPitagoricas2 :: Integer -> [(Integer,Integer,Integer)]
ternasPitagoricas2 x =
  [(a,b,c) | a <- [1..x],
             b <- [a+1..x-a],
             let c = x-a-b,
             a^2+b^2 == c^2]

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

-- Todas las ternas pitagóricas primitivas (a,b,c) pueden representarse
-- por
--    a = m^2 - n^2, b = 2*m*n, c = m^2 + n^2,
-- con 1 <= n < m. (Ver en https://bit.ly/35UNY6L ).

ternasPitagoricas3 :: Integer -> [(Integer,Integer,Integer)]
ternasPitagoricas3 x =
  nub [(d*a,d*b,d*c) | d <- [1..x],
                       x `mod` d == 0,
                      (a,b,c) <- aux (x `div` d)]
  where
    aux y = [(a,b,c) | m <- [2..limite],
                       n <- [1..m-1],
                       let [a,b] = sort [m^2 - n^2, 2*m*n],
                       let c = m^2 + n^2,
                       a+b+c == y]
      where limite = ceiling (sqrt (fromIntegral y))

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

-- La propiedad es
prop_ternasPitagoricas :: Positive Integer -> Bool
prop_ternasPitagoricas (Positive x) =
  all (== (ternasPitagoricas1 x))
      [ternasPitagoricas2 x,
       ternasPitagoricas3 x]

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

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

-- La comparación es
--    λ> ternasPitagoricas1 200
--    [(40,75,85)]
--    (1.90 secs, 2,404,800,856 bytes)
--    λ> ternasPitagoricas2 200
--    [(40,75,85)]
--    (0.06 secs, 19,334,232 bytes)
--    λ> ternasPitagoricas3 200
--    [(40,75,85)]
--    (0.01 secs, 994,224 bytes)
--
--    λ> ternasPitagoricas2 3000
--    [(500,1200,1300),(600,1125,1275),(750,1000,1250)]
--    (4.41 secs, 4,354,148,136 bytes)
--    λ> ternasPitagoricas3 3000
--    [(500,1200,1300),(600,1125,1275),(750,1000,1250)]
--    (0.05 secs, 17,110,360 bytes)

import Data.List (nub,sort)

import Test.QuickCheck

-- 1ª solución --

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

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

ternasPitagoricas1 x =

[(a,b,c) | a <- [0..x],

b <- [a+1..x],

c <- [b+1..x],

a^2 + b^2 == c^2,

a+b+c == x]

-- 2ª solución --

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

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

ternasPitagoricas2 x =

[(a,b,c) | a <- [1..x],

b <- [a+1..x-a],

let c = x-a-b,

a^2+b^2 == c^2]

-- 3ª solución --

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

-- Todas las ternas pitagóricas primitivas (a,b,c) pueden representarse

-- por

-- a = m^2 - n^2, b = 2*m*n, c = m^2 + n^2,

-- con 1 <= n < m. (Ver en https://bit.ly/35UNY6L ).

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

ternasPitagoricas3 x =

nub [(d*a,d*b,d*c) | d <- [1..x],

x `mod` d == 0,

(a,b,c) <- aux (x `div` d)]

where

aux y = [(a,b,c) | m <- [2..limite],

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

let [a,b] = sort [m^2 - n^2, 2*m*n],

let c = m^2 + n^2,

a+b+c == y]

where limite = ceiling (sqrt (fromIntegral y))

-- Equivalencia de las definiciones

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

-- La propiedad es

prop_ternasPitagoricas :: Positive Integer -> Bool

prop_ternasPitagoricas (Positive x) =

all (== (ternasPitagoricas1 x))

[ternasPitagoricas2 x,

ternasPitagoricas3 x]

-- La comprobación es

-- λ> quickCheck prop_ternasPitagoricas

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> ternasPitagoricas1 200

-- [(40,75,85)]

-- (1.90 secs, 2,404,800,856 bytes)

-- λ> ternasPitagoricas2 200

-- [(40,75,85)]

-- (0.06 secs, 19,334,232 bytes)

-- λ> ternasPitagoricas3 200

-- [(40,75,85)]

-- (0.01 secs, 994,224 bytes)

-- λ> ternasPitagoricas2 3000

-- [(500,1200,1300),(600,1125,1275),(750,1000,1250)]

-- (4.41 secs, 4,354,148,136 bytes)

-- λ> ternasPitagoricas3 3000

-- [(500,1200,1300),(600,1125,1275),(750,1000,1250)]

-- (0.05 secs, 17,110,360 bytes)

El código se encuentra en GitHub.

Suma de múltiplos de 3 o de 5

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

Los números naturales menores que 10 que son múltiplos de 3 ó 5 son 3, 5, 6 y 9. La suma de estos múltiplos es 23.

Definir la función

   sumaMultiplos :: Integer -> Integer

1	sumaMultiplos :: Integer -> Integer

tal que (sumaMultiplos n) es la suma de todos los múltiplos de 3 ó 5 menores que n. Por ejemplo,

   sumaMultiplos 10      ==  23
   sumaMultiplos (10^2)  ==  2318
   sumaMultiplos (10^3)  ==  233168
   sumaMultiplos (10^4)  ==  23331668
   sumaMultiplos (10^5)  ==  2333316668
   sumaMultiplos (10^6)  ==  233333166668
   sumaMultiplos (10^7)  ==  23333331666668

sumaMultiplos 10 == 23

sumaMultiplos (10^2) == 2318

sumaMultiplos (10^3) == 233168

sumaMultiplos (10^4) == 23331668

sumaMultiplos (10^5) == 2333316668

sumaMultiplos (10^6) == 233333166668

sumaMultiplos (10^7) == 23333331666668

Soluciones

import Data.List (nub, union)
import Test.QuickCheck (Positive(..), quickCheck)

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

sumaMultiplos1 :: Integer -> Integer
sumaMultiplos1 n = sum [x | x <- [1..n-1], multiplo x 3 || multiplo x 5]

-- (multiplo x y) se verifica si x es múltiplo de y. Por ejemplo,
--    multiplo 6 3  ==  True
--    multiplo 6 4  ==  False
multiplo :: Integer -> Integer -> Bool
multiplo x y = mod x y == 0

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

sumaMultiplos2 :: Integer -> Integer
sumaMultiplos2 n = sum [x | x <- [1..n-1], gcd x 15 > 1]

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

sumaMultiplos3 :: Integer -> Integer
sumaMultiplos3 n = sum [3,6..n-1] + sum [5,10..n-1] - sum [15,30..n-1]

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

sumaMultiplos4 :: Integer -> Integer
sumaMultiplos4 n = sum (nub ([3,6..n-1] ++ [5,10..n-1]))

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

sumaMultiplos5 :: Integer -> Integer
sumaMultiplos5 n = sum ([3,6..n-1] `union` [5,10..n-1])

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

sumaMultiplos6 :: Integer -> Integer
sumaMultiplos6 n = suma 3 n + suma 5 n - suma 15 n

-- (suma d x) es la suma de los múltiplos de d menores que x. Por
-- ejemplo,
--    suma 3 10  ==  18
--    suma 5 10  ==  5
suma :: Integer -> Integer -> Integer
suma d x = (a+b)*n `div` 2
    where a = d
          b = d * ((x-1) `div` d)
          n = 1 + (b-a) `div` d

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

-- La propiedad es
prop_sumaMultiplos :: Positive Integer -> Bool
prop_sumaMultiplos (Positive n) =
  all (== (sumaMultiplos1 n))
      [f n | f <- [sumaMultiplos1,
                   sumaMultiplos2,
                   sumaMultiplos3,
                   sumaMultiplos4,
                   sumaMultiplos5,
                   sumaMultiplos6]]

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

-- La comparación es
--    λ> sumaMultiplos1 (5*10^4)
--    583291668
--    (0.05 secs, 21,446,456 bytes)
--    λ> sumaMultiplos2 (5*10^4)
--    583291668
--    (0.05 secs, 26,804,944 bytes)
--    λ> sumaMultiplos3 (5*10^4)
--    583291668
--    (0.01 secs, 5,136,728 bytes)
--    λ> sumaMultiplos4 (5*10^4)
--    583291668
--    (3.05 secs, 7,474,304 bytes)
--    λ> sumaMultiplos5 (5*10^4)
--    583291668
--    (5.14 secs, 12,787,717,152 bytes)
--    λ> sumaMultiplos6 (5*10^4)
--    583291668
--    (0.01 secs, 108,448 bytes)
--
--    λ> sumaMultiplos1 (3*10^6)
--    2099998500000
--    (2.14 secs, 1,281,805,696 bytes)
--    λ> sumaMultiplos2 (3*10^6)
--    2099998500000
--    (1.86 secs, 1,603,407,272 bytes)
--    λ> sumaMultiplos3 (3*10^6)
--    2099998500000
--    (0.39 secs, 304,681,080 bytes)
--    λ> sumaMultiplos6 (3*10^6)
--    2099998500000
--    (0.01 secs, 112,544 bytes)
--
--    λ> sumaMultiplos3 (10^7)
--    23333331666668
--    (1.69 secs, 1,015,468,352 bytes)
--    λ> sumaMultiplos6 (10^7)
--    23333331666668
--    (0.01 secs, 112,336 bytes)

100

101

102

103

104

105

106

107

108

109

110

111

import Data.List (nub, union)

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

-- 1ª solución

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

sumaMultiplos1 :: Integer -> Integer

sumaMultiplos1 n = sum [x | x <- [1..n-1], multiplo x 3 || multiplo x 5]

-- (multiplo x y) se verifica si x es múltiplo de y. Por ejemplo,

-- multiplo 6 3 == True

-- multiplo 6 4 == False

multiplo :: Integer -> Integer -> Bool

multiplo x y = mod x y == 0

-- 2ª solución --

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

sumaMultiplos2 :: Integer -> Integer

sumaMultiplos2 n = sum [x | x <- [1..n-1], gcd x 15 > 1]

-- 3ª solución --

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

sumaMultiplos3 :: Integer -> Integer

sumaMultiplos3 n = sum [3,6..n-1] + sum [5,10..n-1] - sum [15,30..n-1]

-- 4ª solución --

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

sumaMultiplos4 :: Integer -> Integer

sumaMultiplos4 n = sum (nub ([3,6..n-1] ++ [5,10..n-1]))

-- 5ª solución --

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

sumaMultiplos5 :: Integer -> Integer

sumaMultiplos5 n = sum ([3,6..n-1] `union` [5,10..n-1])

-- 6ª solución --

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

sumaMultiplos6 :: Integer -> Integer

sumaMultiplos6 n = suma 3 n + suma 5 n - suma 15 n

-- (suma d x) es la suma de los múltiplos de d menores que x. Por

-- ejemplo,

-- suma 3 10 == 18

-- suma 5 10 == 5

suma :: Integer -> Integer -> Integer

suma d x = (a+b)*n `div` 2

where a = d

b = d * ((x-1) `div` d)

n = 1 + (b-a) `div` d

-- Equivalencia de definiciones

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

-- La propiedad es

prop_sumaMultiplos :: Positive Integer -> Bool

prop_sumaMultiplos (Positive n) =

all (== (sumaMultiplos1 n))

[f n | f <- [sumaMultiplos1,

sumaMultiplos2,

sumaMultiplos3,

sumaMultiplos4,

sumaMultiplos5,

sumaMultiplos6]]

-- Comparación de eficiencia

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

-- La comparación es

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

-- 583291668

-- (0.05 secs, 21,446,456 bytes)

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

-- 583291668

-- (0.05 secs, 26,804,944 bytes)

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

-- 583291668

-- (0.01 secs, 5,136,728 bytes)

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

-- 583291668

-- (3.05 secs, 7,474,304 bytes)

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

-- 583291668

-- (5.14 secs, 12,787,717,152 bytes)

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

-- 583291668

-- (0.01 secs, 108,448 bytes)

-- λ> sumaMultiplos1 (3*10^6)

-- 2099998500000

-- (2.14 secs, 1,281,805,696 bytes)

-- λ> sumaMultiplos2 (3*10^6)

-- 2099998500000

-- (1.86 secs, 1,603,407,272 bytes)

-- λ> sumaMultiplos3 (3*10^6)

-- 2099998500000

-- (0.39 secs, 304,681,080 bytes)

-- λ> sumaMultiplos6 (3*10^6)

-- 2099998500000

-- (0.01 secs, 112,544 bytes)

-- λ> sumaMultiplos3 (10^7)

-- 23333331666668

-- (1.69 secs, 1,015,468,352 bytes)

-- λ> sumaMultiplos6 (10^7)

-- 23333331666668

-- (0.01 secs, 112,336 bytes)

El código se encuentra en GitHub.

Número de ocurrencias de elementos

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

Definir la función

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

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

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

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

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

Soluciones

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

import Data.List (group, nub, sort)

import Data.Maybe (fromJust)

import qualified Data.Map as M

import Test.QuickCheck

-- 1ª solución

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

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

ocurrenciasElementos1 xs =

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

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

-- ejemplo,

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

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

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

-- 2ª solución

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

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

ocurrenciasElementos2 xs = map ocurrencias (nub xs)

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

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

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

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

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

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

-- 3ª solución

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

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

ocurrenciasElementos3 xs = map ocurrencias (nub xs)

where diccionario = dicFrecuencias xs

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

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

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

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

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

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

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

-- 4ª solución

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

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

ocurrenciasElementos4 = foldl aux []

where

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

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

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

-- Equivalencia de las definiciones

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

-- La propiedad es

prop_ocurrenciasElementos :: [Integer] -> Bool

prop_ocurrenciasElementos xs =

all (== (ocurrenciasElementos1 xs))

[f xs | f <- [ocurrenciasElementos2,

ocurrenciasElementos3,

ocurrenciasElementos4]]

-- La comprobación es

-- λ> quickCheck prop_ocurrenciasElementos

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

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

-- ('5',42935)

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

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

-- ('5',42935)

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

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

-- ('5',42935)

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

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

-- ('5',42935)

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

El código se encuentra en GitHub.

Producto de los elementos de la diagonal principal

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

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

Definir la función

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

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

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

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

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

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

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

Soluciones

import Data.List (genericReplicate)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

import Data.List (genericReplicate)

-- 1ª solución

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

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

productoDiagonal1 xss = product (diagonal1 xss)

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

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

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

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

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

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

diagonal1 _ = []

-- 2ª solución

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

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

productoDiagonal2 = product . diagonal1

-- 3ª solución

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

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

productoDiagonal3 = product . diagonal3

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

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

where n = length (head xss) - 1

-- 4ª solución

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

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

productoDiagonal4 [] = 1

productoDiagonal4 [[]] = 1

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

-- 5ª solución

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

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

productoDiagonal5 xss = product (zipWith (!!) xss [0..k])

where m = length xss

n = length (head xss)

k = min m n - 1

-- Comparación de eficiencia

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

ejemplo :: Integer -> [[Integer]]

ejemplo n = genericReplicate n [1..n]

-- La comparación es

-- λ> length (show (productoDiagonal1 (ejemplo 7000)))

-- 23878

-- (1.23 secs, 3,396,129,424 bytes)

-- λ> length (show (productoDiagonal2 (ejemplo 7000)))

-- 23878

-- (0.94 secs, 3,396,127,680 bytes)

-- λ> length (show (productoDiagonal3 (ejemplo 7000)))

-- 23878

-- (0.09 secs, 44,841,864 bytes)

-- λ> length (show (productoDiagonal4 (ejemplo 7000)))

-- 23878

-- (0.96 secs, 3,614,137,840 bytes)

-- λ> length (show (productoDiagonal5 (ejemplo 7000)))

-- 23878

-- (0.07 secs, 44,168,984 bytes)

-- λ> length (show (productoDiagonal3 (ejemplo 70000)))

-- 308760

-- (8.26 secs, 5,359,752,408 bytes)

-- λ> length (show (productoDiagonal5 (ejemplo 70000)))

-- 308760

-- (9.34 secs, 5,353,035,656 bytes)

El código se encuentra en GitHub.

Sistema factorádico de numeración

PorJosé A. Alonso 28-enero-202215-abril-2022

El sistema factorádico es un sistema numérico basado en factoriales en el que el n-ésimo dígito, empezando desde la derecha, debe ser multiplicado por n! Por ejemplo, el número «341010» en el sistema factorádico es 463 en el sistema decimal ya que

   3×5! + 4×4! + 1×3! + 0×2! + 1×1! + 0×0! = 463

1	3×5! + 4×4! + 1×3! + 0×2! + 1×1! + 0×0! = 463

En este sistema numérico, el dígito de más a la derecha es siempre 0, el segundo 0 o 1, el tercero 0,1 o 2 y así sucesivamente.

Con los dígitos del 0 al 9 el mayor número que podemos codificar es el 10!-1 = 3628799. En cambio, si lo ampliamos con las letras A a Z podemos codificar hasta 36!-1 = 37199332678990121746799944815083519999999910.

Definir las funciones

   factoradicoAdecimal :: String -> Integer
   decimalAfactoradico :: Integer -> String

1 2	factoradicoAdecimal :: String -> Integer decimalAfactoradico :: Integer -> String

tales que

(factoradicoAdecimal cs) es el número decimal correspondiente al número factorádico cs. Por ejemplo,

     λ> decimalAfactoradico 463
     "341010"
     λ> decimalAfactoradico 2022
     "2441000"
     λ> decimalAfactoradico 36288000
     "A0000000000"
     λ> map decimalAfactoradico [1..10]
     ["10","100","110","200","210","1000","1010","1100","1110","1200"]
     λ> decimalAfactoradico 37199332678990121746799944815083519999999
     "3KXWVUTSRQPONMLKJIHGFEDCBA9876543210"

λ> decimalAfactoradico 463

"341010"

λ> decimalAfactoradico 2022

"2441000"

λ> decimalAfactoradico 36288000

"A0000000000"

λ> map decimalAfactoradico [1..10]

["10","100","110","200","210","1000","1010","1100","1110","1200"]

λ> decimalAfactoradico 37199332678990121746799944815083519999999

"3KXWVUTSRQPONMLKJIHGFEDCBA9876543210"

(decimalAfactoradico n) es el número factorádico correpondiente al número decimal n. Por ejemplo,

     λ> factoradicoAdecimal "341010"
     463
     λ> factoradicoAdecimal "2441000"
     2022
     λ> factoradicoAdecimal "A0000000000"
     36288000
     λ> map factoradicoAdecimal ["10","100","110","200","210","1000","1010","1100","1110","1200"]
     [1,2,3,4,5,6,7,8,9,10]
     λ> factoradicoAdecimal "3KXWVUTSRQPONMLKJIHGFEDCBA9876543210"
     37199332678990121746799944815083519999999

λ> factoradicoAdecimal "341010"

463

λ> factoradicoAdecimal "2441000"

2022

λ> factoradicoAdecimal "A0000000000"

36288000

λ> map factoradicoAdecimal ["10","100","110","200","210","1000","1010","1100","1110","1200"]

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

λ> factoradicoAdecimal "3KXWVUTSRQPONMLKJIHGFEDCBA9876543210"

37199332678990121746799944815083519999999

Comprobar con QuickCheck que, para cualquier entero positivo n,

   factoradicoAdecimal (decimalAfactoradico n) == n

1	factoradicoAdecimal (decimalAfactoradico n) == n

Soluciones

{-# LANGUAGE TupleSections #-}

import Data.List (genericIndex, genericLength)
import qualified Data.Map as M
import Test.QuickCheck
import Test.Hspec

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

factoradicoAdecimal1 :: String -> Integer
factoradicoAdecimal1 cs = sum (zipWith (*) xs ys)
  where xs = map caracterAentero cs
        n  = length cs
        ys = reverse (take n facts)

-- (caracterAentero c) es la posición del carácter c en la lista de
-- caracteres ['0', '1',..., '9', 'A', 'B',..., 'Z']. Por ejemplo,
--    caracterAentero '0'  ==  0
--    caracterAentero '1'  ==  1
--    caracterAentero '9'  ==  9
--    caracterAentero 'A'  ==  10
--    caracterAentero 'B'  ==  11
--    caracterAentero 'Z'  ==  35
caracterAentero :: Char -> Integer
caracterAentero c =
  head [n | (n,x) <- zip [0..] caracteres, x == c]

-- caracteres es la lista de caracteres
-- ['0', '1',..., '9', 'A', 'B',..., 'Z']
caracteres :: String
caracteres = ['0'..'9'] ++ ['A'..'Z']

-- facts es la lista de los factoriales. Por ejemplo,
--    λ> take 12 facts
--    [1,1,2,6,24,120,720,5040,40320,362880,3628800,39916800]
facts :: [Integer]
facts = scanl (*) 1 [1..]

decimalAfactoradico1 :: Integer -> String
decimalAfactoradico1 n = aux n (reverse (takeWhile (<=n) facts))
  where aux 0 xs     = ['0' | _ <- xs]
        aux m (x:xs) = enteroAcaracter (m `div` x) : aux (m `mod` x) xs

-- (enteroAcaracter k) es el k-ésimo elemento de la lista
-- ['0', '1',..., '9', 'A', 'B',..., 'Z']. . Por ejemplo,
--    enteroAcaracter 0   ==  '0'
--    enteroAcaracter 1   ==  '1'
--    enteroAcaracter 9   ==  '9'
--    enteroAcaracter 10  ==  'A'
--    enteroAcaracter 11  ==  'B'
--    enteroAcaracter 35  ==  'Z'
enteroAcaracter :: Integer -> Char
enteroAcaracter k = caracteres `genericIndex` k

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

factoradicoAdecimal2 :: String -> Integer
factoradicoAdecimal2 cs = sum (zipWith (*) xs ys)
    where xs = map caracterAentero2 cs
          n  = length cs
          ys = reverse (take n facts)

-- (caracterAentero2 c) es la posición del carácter c en la lista de
-- caracteres ['0', '1',..., '9', 'A', 'B',..., 'Z']. Por ejemplo,
--    caracterAentero2 '0'  ==  0
--    caracterAentero2 '1'  ==  1
--    caracterAentero2 '9'  ==  9
--    caracterAentero2 'A'  ==  10
--    caracterAentero2 'B'  ==  11
--    caracterAentero2 'Z'  ==  35
caracterAentero2 :: Char -> Integer
caracterAentero2 c = caracteresEnteros M.! c

-- caracteresEnteros es el diccionario cuyas claves son los caracteres y
-- las claves son los números de 0 a 35.
caracteresEnteros :: M.Map Char Integer
caracteresEnteros = M.fromList (zip (['0'..'9'] ++ ['A'..'Z']) [0..])

decimalAfactoradico2 :: Integer -> String
decimalAfactoradico2 n = aux n (reverse (takeWhile (<=n) facts))
    where aux 0 xs     = ['0' | _ <- xs]
          aux m (x:xs) = enteroAcaracter2 (m `div` x) : aux (m `mod` x) xs

-- (enteroAcaracter2 k) es el k-ésimo elemento de la lista
-- ['0', '1',..., '9', 'A', 'B',..., 'Z']. . Por ejemplo,
--    enteroAcaracter2 0   ==  '0'
--    enteroAcaracter2 1   ==  '1'
--    enteroAcaracter2 9   ==  '9'
--    enteroAcaracter2 10  ==  'A'
--    enteroAcaracter2 11  ==  'B'
--    enteroAcaracter2 35  ==  'Z'
enteroAcaracter2 :: Integer -> Char
enteroAcaracter2 k = enterosCaracteres M.! k

-- enterosCaracteres es el diccionario cuyas claves son los número de 0
-- a 35 y las claves son los caracteres.
enterosCaracteres :: M.Map Integer Char
enterosCaracteres = M.fromList (zip [0..] caracteres)

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

factoradicoAdecimal3 :: String -> Integer
factoradicoAdecimal3 cs =
  sum (zipWith (*) facts (reverse (map caracterAentero3 cs)))

-- (caracterAentero3 c) es la posición del carácter c en la lista de
-- caracteres ['0', '1',..., '9', 'A', 'B',..., 'Z']. Por ejemplo,
--    caracterAentero3 '0'  ==  0
--    caracterAentero3 '1'  ==  1
--    caracterAentero3 '9'  ==  9
--    caracterAentero3 'A'  ==  10
--    caracterAentero3 'B'  ==  11
--    caracterAentero3 'Z'  ==  35
caracterAentero3 :: Char -> Integer
caracterAentero3 c =
  genericLength (takeWhile (/= c) caracteres)

decimalAfactoradico3 :: Integer -> String
decimalAfactoradico3 n = aux "" 2 (n, 0)
  where aux s _ (0, 0) = s
        aux s n (d, r) = aux (enteroAcaracter3 r: s) (n + 1) (d `divMod` n)

-- (enteroAcaracter3 k) es el k-ésimo elemento de la lista
-- ['0', '1',..., '9', 'A', 'B',..., 'Z']. . Por ejemplo,
--    enteroAcaracter3 0   ==  '0'
--    enteroAcaracter3 1   ==  '1'
--    enteroAcaracter3 9   ==  '9'
--    enteroAcaracter3 10  ==  'A'
--    enteroAcaracter3 11  ==  'B'
--    enteroAcaracter3 35  ==  'Z'
enteroAcaracter3 :: Integer -> Char
enteroAcaracter3 n =
  caracteres !! (fromInteger n)

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

factoradicoAdecimal4 :: String -> Integer
factoradicoAdecimal4 =
  sum . zipWith (*) facts . reverse . map caracterAentero4

-- (caracterAentero4 c) es la posición del carácter c en la lista de
-- caracteres ['0', '1',..., '9', 'A', 'B',..., 'Z']. Por ejemplo,
--    caracterAentero4 '0'  ==  0
--    caracterAentero4 '1'  ==  1
--    caracterAentero4 '9'  ==  9
--    caracterAentero4 'A'  ==  10
--    caracterAentero4 'B'  ==  11
--    caracterAentero4 'Z'  ==  35
caracterAentero4 :: Char -> Integer
caracterAentero4 =
  genericLength . flip takeWhile caracteres . (/=)

decimalAfactoradico4 :: Integer -> String
decimalAfactoradico4 = f "" 2 . (, 0)
  where f s _ (0, 0) = s
        f s n (d, r) = f (enteroAcaracter4 r: s) (n + 1) (d `divMod` n)

-- (enteroAcaracter4 k) es el k-ésimo elemento de la lista
-- ['0', '1',..., '9', 'A', 'B',..., 'Z']. . Por ejemplo,
--    enteroAcaracter4 0   ==  '0'
--    enteroAcaracter4 1   ==  '1'
--    enteroAcaracter4 9   ==  '9'
--    enteroAcaracter4 10  ==  'A'
--    enteroAcaracter4 11  ==  'B'
--    enteroAcaracter4 35  ==  'Z'
enteroAcaracter4 :: Integer -> Char
enteroAcaracter4 = (caracteres `genericIndex`)

-- Propiedad de inverso
-- ====================

prop_factoradico :: Integer -> Property
prop_factoradico n =
  n >= 0 ==>
  factoradicoAdecimal1 (decimalAfactoradico1 n) == n &&
  factoradicoAdecimal2 (decimalAfactoradico2 n) == n &&
  factoradicoAdecimal3 (decimalAfactoradico3 n) == n &&
  factoradicoAdecimal4 (decimalAfactoradico4 n) == n

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

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

-- La comparación es
--    λ> length (decimalAfactoradico1 (10^300000))
--    68191
--    (2.46 secs, 9,088,634,744 bytes)
--    λ> length (decimalAfactoradico2 (10^300000))
--    68191
--    (2.36 secs, 9,088,634,800 bytes)
--    λ> length (decimalAfactoradico3 (10^300000))
--    68191
--    (2.18 secs, 4,490,856,416 bytes)
--    λ> length (decimalAfactoradico4 (10^300000))
--    68191
--    (1.98 secs, 4,490,311,536 bytes)
--
--    λ> length (show (factoradicoAdecimal1 (show (10^50000))))
--    213237
--    (0.93 secs, 2,654,156,680 bytes)
--    λ> length (show (factoradicoAdecimal2 (show (10^50000))))
--    213237
--    (0.51 secs, 2,633,367,168 bytes)
--    λ> length (show (factoradicoAdecimal3 (show (10^50000))))
--    213237
--    (0.93 secs, 2,635,792,192 bytes)
--    λ> length (show (factoradicoAdecimal4 (show (10^50000))))
--    213237
--    (0.43 secs, 2,636,996,848 bytes)

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

{-# LANGUAGE TupleSections #-}

import Data.List (genericIndex, genericLength)

import qualified Data.Map as M

import Test.QuickCheck

import Test.Hspec

-- 1ª solución

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

factoradicoAdecimal1 :: String -> Integer

factoradicoAdecimal1 cs = sum (zipWith (*) xs ys)

where xs = map caracterAentero cs

n = length cs

ys = reverse (take n facts)

-- (caracterAentero c) es la posición del carácter c en la lista de

-- caracteres ['0', '1',..., '9', 'A', 'B',..., 'Z']. Por ejemplo,

-- caracterAentero '0' == 0

-- caracterAentero '1' == 1

-- caracterAentero '9' == 9

-- caracterAentero 'A' == 10

-- caracterAentero 'B' == 11

-- caracterAentero 'Z' == 35

caracterAentero :: Char -> Integer

caracterAentero c =

head [n | (n,x) <- zip [0..] caracteres, x == c]

-- caracteres es la lista de caracteres

-- ['0', '1',..., '9', 'A', 'B',..., 'Z']

caracteres :: String

caracteres = ['0'..'9'] ++ ['A'..'Z']

-- facts es la lista de los factoriales. Por ejemplo,

-- λ> take 12 facts

-- [1,1,2,6,24,120,720,5040,40320,362880,3628800,39916800]

facts :: [Integer]

facts = scanl (*) 1 [1..]

decimalAfactoradico1 :: Integer -> String

decimalAfactoradico1 n = aux n (reverse (takeWhile (<=n) facts))

where aux 0 xs = ['0' | _ <- xs]

aux m (x:xs) = enteroAcaracter (m `div` x) : aux (m `mod` x) xs

-- (enteroAcaracter k) es el k-ésimo elemento de la lista

-- ['0', '1',..., '9', 'A', 'B',..., 'Z']. . Por ejemplo,

-- enteroAcaracter 0 == '0'

-- enteroAcaracter 1 == '1'

-- enteroAcaracter 9 == '9'

-- enteroAcaracter 10 == 'A'

-- enteroAcaracter 11 == 'B'

-- enteroAcaracter 35 == 'Z'

enteroAcaracter :: Integer -> Char

enteroAcaracter k = caracteres `genericIndex` k

-- 2ª solución

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

factoradicoAdecimal2 :: String -> Integer

factoradicoAdecimal2 cs = sum (zipWith (*) xs ys)

where xs = map caracterAentero2 cs

n = length cs

ys = reverse (take n facts)

-- (caracterAentero2 c) es la posición del carácter c en la lista de

-- caracteres ['0', '1',..., '9', 'A', 'B',..., 'Z']. Por ejemplo,

-- caracterAentero2 '0' == 0

-- caracterAentero2 '1' == 1

-- caracterAentero2 '9' == 9

-- caracterAentero2 'A' == 10

-- caracterAentero2 'B' == 11

-- caracterAentero2 'Z' == 35

caracterAentero2 :: Char -> Integer

caracterAentero2 c = caracteresEnteros M.! c

-- caracteresEnteros es el diccionario cuyas claves son los caracteres y

-- las claves son los números de 0 a 35.

caracteresEnteros :: M.Map Char Integer

caracteresEnteros = M.fromList (zip (['0'..'9'] ++ ['A'..'Z']) [0..])

decimalAfactoradico2 :: Integer -> String

decimalAfactoradico2 n = aux n (reverse (takeWhile (<=n) facts))

where aux 0 xs = ['0' | _ <- xs]

aux m (x:xs) = enteroAcaracter2 (m `div` x) : aux (m `mod` x) xs

-- (enteroAcaracter2 k) es el k-ésimo elemento de la lista

-- ['0', '1',..., '9', 'A', 'B',..., 'Z']. . Por ejemplo,

-- enteroAcaracter2 0 == '0'

-- enteroAcaracter2 1 == '1'

-- enteroAcaracter2 9 == '9'

-- enteroAcaracter2 10 == 'A'

-- enteroAcaracter2 11 == 'B'

-- enteroAcaracter2 35 == 'Z'

enteroAcaracter2 :: Integer -> Char

enteroAcaracter2 k = enterosCaracteres M.! k

-- enterosCaracteres es el diccionario cuyas claves son los número de 0

-- a 35 y las claves son los caracteres.

enterosCaracteres :: M.Map Integer Char

enterosCaracteres = M.fromList (zip [0..] caracteres)

-- 3ª solución

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

factoradicoAdecimal3 :: String -> Integer

factoradicoAdecimal3 cs =

sum (zipWith (*) facts (reverse (map caracterAentero3 cs)))

-- (caracterAentero3 c) es la posición del carácter c en la lista de

-- caracteres ['0', '1',..., '9', 'A', 'B',..., 'Z']. Por ejemplo,

-- caracterAentero3 '0' == 0

-- caracterAentero3 '1' == 1

-- caracterAentero3 '9' == 9

-- caracterAentero3 'A' == 10

-- caracterAentero3 'B' == 11

-- caracterAentero3 'Z' == 35

caracterAentero3 :: Char -> Integer

caracterAentero3 c =

genericLength (takeWhile (/= c) caracteres)

decimalAfactoradico3 :: Integer -> String

decimalAfactoradico3 n = aux "" 2 (n, 0)

where aux s _ (0, 0) = s

aux s n (d, r) = aux (enteroAcaracter3 r: s) (n + 1) (d `divMod` n)

-- (enteroAcaracter3 k) es el k-ésimo elemento de la lista

-- ['0', '1',..., '9', 'A', 'B',..., 'Z']. . Por ejemplo,

-- enteroAcaracter3 0 == '0'

-- enteroAcaracter3 1 == '1'

-- enteroAcaracter3 9 == '9'

-- enteroAcaracter3 10 == 'A'

-- enteroAcaracter3 11 == 'B'

-- enteroAcaracter3 35 == 'Z'

enteroAcaracter3 :: Integer -> Char

enteroAcaracter3 n =

caracteres !! (fromInteger n)

-- 4ª solución

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

factoradicoAdecimal4 :: String -> Integer

factoradicoAdecimal4 =

sum . zipWith (*) facts . reverse . map caracterAentero4

-- (caracterAentero4 c) es la posición del carácter c en la lista de

-- caracteres ['0', '1',..., '9', 'A', 'B',..., 'Z']. Por ejemplo,

-- caracterAentero4 '0' == 0

-- caracterAentero4 '1' == 1

-- caracterAentero4 '9' == 9

-- caracterAentero4 'A' == 10

-- caracterAentero4 'B' == 11

-- caracterAentero4 'Z' == 35

caracterAentero4 :: Char -> Integer

caracterAentero4 =

genericLength . flip takeWhile caracteres . (/=)

decimalAfactoradico4 :: Integer -> String

decimalAfactoradico4 = f "" 2 . (, 0)

where f s _ (0, 0) = s

f s n (d, r) = f (enteroAcaracter4 r: s) (n + 1) (d `divMod` n)

-- (enteroAcaracter4 k) es el k-ésimo elemento de la lista

-- ['0', '1',..., '9', 'A', 'B',..., 'Z']. . Por ejemplo,

-- enteroAcaracter4 0 == '0'

-- enteroAcaracter4 1 == '1'

-- enteroAcaracter4 9 == '9'

-- enteroAcaracter4 10 == 'A'

-- enteroAcaracter4 11 == 'B'

-- enteroAcaracter4 35 == 'Z'

enteroAcaracter4 :: Integer -> Char

enteroAcaracter4 = (caracteres `genericIndex`)

-- Propiedad de inverso

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

prop_factoradico :: Integer -> Property

prop_factoradico n =

n >= 0 ==>

factoradicoAdecimal1 (decimalAfactoradico1 n) == n &&

factoradicoAdecimal2 (decimalAfactoradico2 n) == n &&

factoradicoAdecimal3 (decimalAfactoradico3 n) == n &&

factoradicoAdecimal4 (decimalAfactoradico4 n) == n

-- La comprobación es

-- λ> quickCheck prop_factoradico

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> length (decimalAfactoradico1 (10^300000))

-- 68191

-- (2.46 secs, 9,088,634,744 bytes)

-- λ> length (decimalAfactoradico2 (10^300000))

-- 68191

-- (2.36 secs, 9,088,634,800 bytes)

-- λ> length (decimalAfactoradico3 (10^300000))

-- 68191

-- (2.18 secs, 4,490,856,416 bytes)

-- λ> length (decimalAfactoradico4 (10^300000))

-- 68191

-- (1.98 secs, 4,490,311,536 bytes)

-- λ> length (show (factoradicoAdecimal1 (show (10^50000))))

-- 213237

-- (0.93 secs, 2,654,156,680 bytes)

-- λ> length (show (factoradicoAdecimal2 (show (10^50000))))

-- 213237

-- (0.51 secs, 2,633,367,168 bytes)

-- λ> length (show (factoradicoAdecimal3 (show (10^50000))))

-- 213237

-- (0.93 secs, 2,635,792,192 bytes)

-- λ> length (show (factoradicoAdecimal4 (show (10^50000))))

-- 213237

-- (0.43 secs, 2,636,996,848 bytes)

El código se encuentra en GitHub.

Caminos en un grafo

PorJosé A. Alonso 17-mayo-201726-marzo-2022

Definir las funciones

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

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

tales que

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

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

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

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

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

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

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

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

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

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

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

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

[]

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

109601

Nota: Este ejercicio debe realizarse usando únicamente las funciones de la librería de grafos (I1M.Grafo) que se describe aquí y se encuentra aquí.

Soluciones

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

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

[/schedule]

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

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

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

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

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

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

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

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

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

import Data.List (sort)

import I1M.Grafo

import I1M.BusquedaEnEspaciosDeEstados

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

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

where ns = map fst as ++ map snd as

m = minimum ns

n = maximum ns

-- 1ª solución

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

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

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

aux [] = []

aux ((x:xs):yss)

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

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

, z `notElem` (x:xs)]

++ yss)

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

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

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

caminos2 g a b = buscaEE sucesores esFinal inicial

where inicial = [b]

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

, z `notElem` (x:xs)]

esFinal (x:xs) = x == a

-- Comparación de eficiencia

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

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

-- 109601

-- (3.57 secs, 500533816 bytes)

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

-- 109601

-- (3.53 secs, 470814096 bytes)

[/schedule]

Problema del dominó

PorJosé A. Alonso 16-mayo-201726-marzo-2022

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

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

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

[/schedule]

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

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)

[/schedule]

Grafo de divisibilidad

PorJosé A. Alonso 11-mayo-201726-marzo-2022

El grafo de divisibilidad de orden n es el grafo cuyos nodos son los números naturales entre 1 y n, cuyas aristas son los pares (x,y) tales que x divide a y o y divide a x y el coste de cada arista es el cociente entre su mayos 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

1 2	coste 12 == 41 coste 3000 == 605305

Soluciones

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

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

[/schedule]

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

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

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,
                                         elem u t, 
                                         elem v 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]

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

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

import Data.List (delete, sort)

import qualified Data.Set as S

import I1M.Grafo

import I1M.Tabla

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,

elem u t,

elem v 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]

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

[/schedule]

Sucesiones de listas de números

PorJosé A. Alonso 20-mayo-201626-marzo-2022

En la Olimpiada Internacional de Matemáticas del 2012 se propuso el siguiente problema:

Varios enteros positivos se escriben en una lista. Iterativamente, Alicia elige dos números adyacentes x e y tales que x > y y x está a la izquierda de y y reemplaza el par (x,y) por (y+1,x) o (x-1,x). Demostrar que sólo puede aplicar un número finito de dichas iteraciones.

Por ejemplo, las transformadas de la lista [1,3,2] son [1,2,3] y [1,3,3] y las dos obtenidas son finales (es decir, no se les puede aplicar ninguna transformación).

Definir las funciones

   soluciones       :: [Int] -> [Estado]
   finales          :: [Int] -> [[Int]]
   finalesMaximales :: [Int] -> (Int,[[Int]])

soluciones :: [Int] -> [Estado]

finales :: [Int] -> [[Int]]

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

tales que

(soluciones xs) es la lista de pares (n,ys) tales que ys es una lista obtenida aplicándole n transformaciones a xs. Por ejemplo,

     λ> soluciones [1,3,2]
     [(1,[1,3,3]),(1,[1,2,3])]
     λ> sort (nub (soluciones [3,3,2]))
     [(1,[3,3,3]),(2,[2,3,3]),(2,[3,3,3])]
     λ> sort (nub (soluciones [3,2,1]))
     [(2,[2,2,3]),(3,[2,2,3]),(3,[2,3,3]),(3,[3,3,3]),(4,[2,3,3]),(4,[3,3,3])]

λ> soluciones [1,3,2]

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

λ> sort (nub (soluciones [3,3,2]))

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

λ> sort (nub (soluciones [3,2,1]))

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

(finales xs) son las listas obtenidas transformando xs y a las que no se les puede aplicar más transformaciones. Por ejemplo,

     finales [1,2,3]               ==  [[1,2,3]]
     finales [1,3,2]               ==  [[1,2,3],[1,3,3]]
     finales [3,2,1]               ==  [[2,2,3],[2,3,3],[3,3,3]]
     finales [1,3,2,4]             ==  [[1,2,3,4],[1,3,3,4]]
     finales [1,3,2,3]             ==  [[1,2,3,3],[1,3,3,3]]
     length (finales [9,6,0,7,2])  ==  19
     length (finales [80,60..0])   ==  420

finales [1,2,3] == [[1,2,3]]

finales [1,3,2] == [[1,2,3],[1,3,3]]

finales [3,2,1] == [[2,2,3],[2,3,3],[3,3,3]]

finales [1,3,2,4] == [[1,2,3,4],[1,3,3,4]]

finales [1,3,2,3] == [[1,2,3,3],[1,3,3,3]]

length (finales [9,6,0,7,2]) == 19

length (finales [80,60..0]) == 420

(finalesMaximales xs) es el par (n,yss) tal que la longitud de las cadenas más largas de transformaciones a partir de xs e yss es la lista de los estados finales a partir de xs con n transformaciones. Por ejemplo,

     finalesMaximales [9,5,7]   ==  (2,[[6,8,9],[8,8,9]])
     finalesMaximales [3,2,1]   ==  (4,[[2,3,3],[3,3,3]])
     finalesMaximales [3,2..0]  ==  (10,[[2,3,3,3],[3,3,3,3]])
     finalesMaximales [4,3..0]  ==  (20,[[3,4,4,4,4],[4,4,4,4,4]])

finalesMaximales [9,5,7] == (2,[[6,8,9],[8,8,9]])

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

finalesMaximales [3,2..0] == (10,[[2,3,3,3],[3,3,3,3]])

finalesMaximales [4,3..0] == (20,[[3,4,4,4,4],[4,4,4,4,4]])

Soluciones

import Data.List (nub, sort)
import I1M.BusquedaEnEspaciosDeEstados (buscaEE)

type Estado = (Int,[Int])

inicial :: [Int] -> Estado
inicial xs = (0,xs)

esFinal :: Estado -> Bool
esFinal e = null (sucesores e)

--    λ> sucesores [9,6,0,7,2]
--    [[7,9,0,7,2],[8,9,0,7,2],[9,1,6,7,2],[9,5,6,7,2],[9,6,0,3,7],[9,6,0,6,7]]
sucesores :: Estado -> [Estado]
sucesores (_,[])  = []
sucesores (_,[_]) = []
sucesores (n,x:y:xs) | x > y     = [(n+1,y+1:x:xs), (n+1,x-1:x:xs)] ++ yss
                     | otherwise = yss
    where yss = [(m,x:ys) | (m,ys) <- sucesores (n,y:xs)]
                       

soluciones :: [Int] -> [Estado]
soluciones xs =
    buscaEE sucesores esFinal (inicial xs)

finales :: [Int] -> [[Int]]
finales xs =
    sort (nub (map snd (soluciones xs)))
            
finalesMaximales :: [Int] -> (Int,[[Int]])
finalesMaximales xs =
    (m, [xs | (n,xs) <- es, n == m])
    where es    = sort (nub (soluciones xs))
          (m,_) = maximum es

import Data.List (nub, sort)

import I1M.BusquedaEnEspaciosDeEstados (buscaEE)

type Estado = (Int,[Int])

inicial :: [Int] -> Estado

inicial xs = (0,xs)

esFinal :: Estado -> Bool

esFinal e = null (sucesores e)

-- λ> sucesores [9,6,0,7,2]

-- [[7,9,0,7,2],[8,9,0,7,2],[9,1,6,7,2],[9,5,6,7,2],[9,6,0,3,7],[9,6,0,6,7]]

sucesores :: Estado -> [Estado]

sucesores (_,[]) = []

sucesores (_,[_]) = []

sucesores (n,x:y:xs) | x > y = [(n+1,y+1:x:xs), (n+1,x-1:x:xs)] ++ yss

| otherwise = yss

where yss = [(m,x:ys) | (m,ys) <- sucesores (n,y:xs)]

soluciones :: [Int] -> [Estado]

soluciones xs =

buscaEE sucesores esFinal (inicial xs)

finales :: [Int] -> [[Int]]

finales xs =

sort (nub (map snd (soluciones xs)))

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

finalesMaximales xs =

(m, [xs | (n,xs) <- es, n == m])

where es = sort (nub (soluciones xs))

(m,_) = maximum es

Problema del dominó

PorJosé A. Alonso 17-mayo-201626-marzo-2022

Definir, mediante búsqueda en espacio de estados, 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,

   ghci> domino [(1,2),(2,3),(1,4)]
   [[(4,1),(1,2),(2,3)],[(3,2),(2,1),(1,4)]]
   ghci> domino [(1,2),(1,1),(1,4)]
   [[(4,1),(1,1),(1,2)],[(2,1),(1,1),(1,4)]]
   ghci> domino [(1,2),(3,4),(2,3)]
   [[(1,2),(2,3),(3,4)]]
   ghci> domino [(1,2),(2,3),(5,4)]
   []
   ghci> 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)]
   ghci> length (domino [(x,y) | x <- [1..4], y <- [x..4]])
   0

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

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

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

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

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

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

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

[]

ghci> 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)]

ghci> length (domino [(x,y) | x <- [1..4], y <- [x..4]])

Nota: Las librerías necesarias se encuentran en la página de códigos.

Soluciones

import I1M.BusquedaEnEspaciosDeEstados (buscaEE)
import Data.List (delete)

type Ficha  = (Int,Int)

-- Los estados son los pares formados por la listas sin colocar y las
-- colocadas. 
type EstadoDomino = ([Ficha],[Ficha])

inicialDomino :: [Ficha] -> EstadoDomino
inicialDomino fs = (fs,[])

esFinalDomino :: EstadoDomino -> Bool
esFinalDomino (fs,_) = null fs 

sucesoresDomino :: EstadoDomino -> [EstadoDomino]
sucesoresDomino (fs,[]) = [(delete f fs, [f]) | f <- fs]
sucesoresDomino (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] 

solucionesDomino :: [Ficha] -> [EstadoDomino]
solucionesDomino ps = buscaEE sucesoresDomino
                              esFinalDomino         
                              (inicialDomino ps)

domino :: [(Int,Int)] -> [[(Int,Int)]]
domino ps = map snd (solucionesDomino ps)

import I1M.BusquedaEnEspaciosDeEstados (buscaEE)

import Data.List (delete)

type Ficha = (Int,Int)

-- Los estados son los pares formados por la listas sin colocar y las

-- colocadas.

type EstadoDomino = ([Ficha],[Ficha])

inicialDomino :: [Ficha] -> EstadoDomino

inicialDomino fs = (fs,[])

esFinalDomino :: EstadoDomino -> Bool

esFinalDomino (fs,_) = null fs

sucesoresDomino :: EstadoDomino -> [EstadoDomino]

sucesoresDomino (fs,[]) = [(delete f fs, [f]) | f <- fs]

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

solucionesDomino :: [Ficha] -> [EstadoDomino]

solucionesDomino ps = buscaEE sucesoresDomino

esFinalDomino

(inicialDomino ps)

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

domino ps = map snd (solucionesDomino ps)

Caminos en un grafo

PorJosé A. Alonso 2-junio-201526-marzo-2022

Definir las funciones

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

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

tales que

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

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

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

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

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

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

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

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

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

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

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

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

[]

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

109601

Nota: Este ejercicio debe realizarse usando únicamente las funciones de la librería de grafos (I1M.Grafo) que se describe aquí y se encuentra aquí.

Soluciones

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)

Ciclos de un grafo

PorJosé A. Alonso 18-mayo-201526-marzo-2022

Un ciclo en un grafo G es una secuencia [v(1),v(2),v(3),…,v(n)] de nodos de G tal que:

(v(1),v(2)), (v(2),v(3)), (v(3),v(4)), …, (v(n-1),v(n)) son aristas de G,
v(1) = v(n), y
salvo v(1) = v(n), todos los v(i) son distintos entre sí.

Definir la función

   ciclos :: Grafo Int Int -> [[Int]]

1	ciclos :: Grafo Int Int -> [[Int]]

tal que (ciclos g) es la lista de ciclos de g. Por ejemplo, si g1 y g2 son los grafos definidos por

   g1, g2 :: Grafo Int Int
   g1 = creaGrafo D (1,4) [(1,2,0),(2,3,0),(2,4,0),(4,1,0)]
   g2 = creaGrafo D (1,4) [(1,2,0),(2,1,0),(2,4,0),(4,1,0)]

g1, g2 :: Grafo Int Int

g1 = creaGrafo D (1,4) [(1,2,0),(2,3,0),(2,4,0),(4,1,0)]

g2 = creaGrafo D (1,4) [(1,2,0),(2,1,0),(2,4,0),(4,1,0)]

entonces

   ciclos g1  ==  [[1,2,4,1],[2,4,1,2],[4,1,2,4]]
   ciclos g2  ==  [[1,2,1],[1,2,4,1],[2,1,2],[2,4,1,2],[4,1,2,4]]

1 2	ciclos g1 == [[1,2,4,1],[2,4,1,2],[4,1,2,4]] ciclos g2 == [[1,2,1],[1,2,4,1],[2,1,2],[2,4,1,2],[4,1,2,4]]

Nota: Este ejercicio debe realizarse usando únicamente las funciones de la librería de grafos (I1M.Grafo) que se describe aquí y se encuentra aquí.

Soluciones

import Data.List (nub, subsequences, permutations, sort)
import I1M.Grafo

-- 1ª definición (por fuerza bruta)
-- ================================

ciclos1 :: Grafo Int Int -> [[Int]]
ciclos1 g = 
    sort [ys | (x:xs) <- concatMap permutations (subsequences (nodos g)) 
             , let ys = (x:xs) ++ [x]
             , esCiclo ys g]

-- (esCiclo vs g) se verifica si vs es un ciclo en el grafo g. Por
-- ejemplo, 
esCiclo :: [Int] -> Grafo Int Int -> Bool
esCiclo vs g = 
    all (aristaEn g) (zip vs (tail vs)) &&
    head vs == last vs &&
    length (nub vs) == length vs - 1    

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

ciclos2 :: Grafo Int Int -> [[Int]]
ciclos2 g = sort [ys | (x:xs) <- caminos g
                     , let ys = (x:xs) ++ [x]
                     , esCiclo ys g]

-- (caminos g) es la lista de los caminos en el grafo g. Por ejemplo,
--    caminos g1  ==  [[1,2,3],[1,2,4],[2,3],[2,4,1],[3],[4,1,2,3]]
caminos :: Grafo Int Int -> [[Int]]
caminos g = concatMap (caminosDesde g) (nodos g)

-- (caminosDesde g v) es la lista de los caminos en el grafo g a partir
-- del vértice v. Por ejemplo,
--    caminosDesde g1 1  ==  [[1],[1,2],[1,2,3],[1,2,4]]
--    caminosDesde g1 2  ==  [[2],[2,3],[2,4],[2,4,1]]
--    caminosDesde g1 3  ==  [[3]]
--    caminosDesde g1 4  ==  [[4],[4,1],[4,1,2],[4,1,2,3]]
caminosDesde :: Grafo Int Int -> Int -> [[Int]]
caminosDesde g v = 
    map (reverse . fst) $
    concat $ 
    takeWhile (not.null) (iterate (concatMap sucesores) [([v],[v])])
    where sucesores (x:xs,ys) = [(z:x:xs,z:ys) | z <- adyacentes g x
                                               , z `notElem` ys]

-- 3ª solución (Pedro Martín)
-- ==========================

ciclos3 :: Grafo Int Int -> [[Int]]
ciclos3 g = concat [aux [n] (adyacentes g n) | n <- nodos g] where 
    aux _ [] = []
    aux xs (y:ys)
        | notElem y xs = aux (xs ++ [y]) (adyacentes g y) ++ aux xs ys
        | y == head xs = (xs ++ [y]) : aux xs ys
        | otherwise    = aux xs ys

-- 4ª solución (Chema Cortés)
-- ==========================

ciclos4 :: Grafo Int Int -> [[Int]]
ciclos4 g = concat [ caminos a a [] | a <- nodos g ] where
    -- caminos posibles de b hasta a, sin pasar dos veces por un mismo nodo
    caminos a b vs
        | a == b && (not.null) vs = [[b]]
        | otherwise = [ b:xs | c <- adyacentes g b
                             , c `notElem` vs
                             , xs <- caminos a c (c:vs)]

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

-- ghci> let ejemplo n = creaGrafo D (1,n) ((n,1,0) : [(i,i+1,0) | i <- [1..n-1]])
-- 
-- ghci> length (ciclos1 (ejemplo 9))
-- 9
-- (4.92 secs, 1371229152 bytes)
--
-- ghci> length (ciclos2 (ejemplo 9))
-- 9
-- (0.01 secs, 2577736 bytes)
-- 
-- ghci> length (ciclos3 (ejemplo 9))
-- 9
-- (0.01 secs, 1038932 bytes)
-- 
-- ghci> length (ciclos4 (ejemplo 9))
-- 9
-- (0.01 secs, 2589288 bytes)
-- 
-- ghci> length (ciclos2 (ejemplo 400))
-- 400
-- (11.74 secs, 5148997000 bytes)
-- 
-- ghci> length (ciclos3 (ejemplo 400))
-- 400
-- (4.99 secs, 936520100 bytes)
-- 
-- ghci> length (ciclos4 (ejemplo 400))
-- 400
-- (1.56 secs, 66701772 bytes)

100

101

102

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

import I1M.Grafo

-- 1ª definición (por fuerza bruta)

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

ciclos1 :: Grafo Int Int -> [[Int]]

ciclos1 g =

sort [ys | (x:xs) <- concatMap permutations (subsequences (nodos g))

, let ys = (x:xs) ++ [x]

, esCiclo ys g]

-- (esCiclo vs g) se verifica si vs es un ciclo en el grafo g. Por

-- ejemplo,

esCiclo :: [Int] -> Grafo Int Int -> Bool

esCiclo vs g =

all (aristaEn g) (zip vs (tail vs)) &&

head vs == last vs &&

length (nub vs) == length vs - 1

-- 2ª definición

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

ciclos2 :: Grafo Int Int -> [[Int]]

ciclos2 g = sort [ys | (x:xs) <- caminos g

, let ys = (x:xs) ++ [x]

, esCiclo ys g]

-- (caminos g) es la lista de los caminos en el grafo g. Por ejemplo,

-- caminos g1 == [[1,2,3],[1,2,4],[2,3],[2,4,1],[3],[4,1,2,3]]

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

caminos g = concatMap (caminosDesde g) (nodos g)

-- (caminosDesde g v) es la lista de los caminos en el grafo g a partir

-- del vértice v. Por ejemplo,

-- caminosDesde g1 1 == [[1],[1,2],[1,2,3],[1,2,4]]

-- caminosDesde g1 2 == [[2],[2,3],[2,4],[2,4,1]]

-- caminosDesde g1 3 == [[3]]

-- caminosDesde g1 4 == [[4],[4,1],[4,1,2],[4,1,2,3]]

caminosDesde :: Grafo Int Int -> Int -> [[Int]]

caminosDesde g v =

map (reverse . fst) $

concat $

takeWhile (not.null) (iterate (concatMap sucesores) [([v],[v])])

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

, z `notElem` ys]

-- 3ª solución (Pedro Martín)

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

ciclos3 :: Grafo Int Int -> [[Int]]

ciclos3 g = concat [aux [n] (adyacentes g n) | n <- nodos g] where

aux _ [] = []

aux xs (y:ys)

| notElem y xs = aux (xs ++ [y]) (adyacentes g y) ++ aux xs ys

| y == head xs = (xs ++ [y]) : aux xs ys

| otherwise = aux xs ys

-- 4ª solución (Chema Cortés)

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

ciclos4 :: Grafo Int Int -> [[Int]]

ciclos4 g = concat [ caminos a a [] | a <- nodos g ] where

-- caminos posibles de b hasta a, sin pasar dos veces por un mismo nodo

caminos a b vs

| a == b && (not.null) vs = [[b]]

| otherwise = [ b:xs | c <- adyacentes g b

, c `notElem` vs

, xs <- caminos a c (c:vs)]

-- Comparación de eficiencia

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

-- ghci> let ejemplo n = creaGrafo D (1,n) ((n,1,0) : [(i,i+1,0) | i <- [1..n-1]])

-- ghci> length (ciclos1 (ejemplo 9))

-- 9

-- (4.92 secs, 1371229152 bytes)

-- ghci> length (ciclos2 (ejemplo 9))

-- 9

-- (0.01 secs, 2577736 bytes)

-- ghci> length (ciclos3 (ejemplo 9))

-- 9

-- (0.01 secs, 1038932 bytes)

-- ghci> length (ciclos4 (ejemplo 9))

-- 9

-- (0.01 secs, 2589288 bytes)

-- ghci> length (ciclos2 (ejemplo 400))

-- 400

-- (11.74 secs, 5148997000 bytes)

-- ghci> length (ciclos3 (ejemplo 400))

-- 400

-- (4.99 secs, 936520100 bytes)

-- ghci> length (ciclos4 (ejemplo 400))

-- 400

-- (1.56 secs, 66701772 bytes)

Máxima suma de caminos en un triángulo

Soluciones

Mayor órbita de la sucesión de Collatz

Soluciones

Ternas pitagóricas con suma dada

Soluciones

Suma de múltiplos de 3 o de 5

Soluciones

Número de ocurrencias de elementos

Soluciones

Producto de los elementos de la diagonal principal

Soluciones

Sistema factorádico de numeración

Soluciones

Caminos en un grafo

Soluciones

Problema del dominó

Soluciones

Grafo de divisibilidad

Soluciones

Sucesiones de listas de números

Soluciones

Problema del dominó

Soluciones

Caminos en un grafo

Soluciones

Ciclos de un grafo

Soluciones

Entradas recientes

Buscar

Correo electrónico