delete – Exercitium

Conjunto de primos relativos

PorJosé A. Alonso 30-marzo-20226-abril-2022

Dos números enteros positivos son primos relativos si no tienen ningún factor primo en común; es decit, si 1 es su único divisor común. Por ejemplo, 6 y 35 son primos entre sí, pero 6 y 27 no lo son porque ambos son divisibles por 3.

Definir la función

   primosRelativos :: [Int] -> Bool

1	primosRelativos :: [Int] -> Bool

tal que (primosRelativos xs) se verifica si los elementos de xs son primos relativos dos a dos. Por ejemplo,

   primosRelativos [6,35]         ==  True
   primosRelativos [6,27]         ==  False
   primosRelativos [2,3,4]        ==  False
   primosRelativos [6,35,11]      ==  True
   primosRelativos [6,35,11,221]  ==  True
   primosRelativos [6,35,11,231]  ==  False

primosRelativos [6,35] == True

primosRelativos [6,27] == False

primosRelativos [2,3,4] == False

primosRelativos [6,35,11] == True

primosRelativos [6,35,11,221] == True

primosRelativos [6,35,11,231] == False

Soluciones

import Test.QuickCheck
import Data.List (delete, intersect)
import Data.Numbers.Primes (primeFactors, primes)
import qualified Data.Set as S (disjoint, fromList)

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

primosRelativos1 :: [Int] -> Bool
primosRelativos1 []     = True
primosRelativos1 (x:xs) =
  and [sonPrimosRelativos1 x y | y <- xs] && primosRelativos1 xs

-- (sonPrimosRelativos x y) se verifica si x e y son primos
-- relativos. Por ejemplo,
--    sonPrimosRelativos1 6 35  ==  True
--    sonPrimosRelativos1 6 27  ==  False
sonPrimosRelativos1 :: Int -> Int -> Bool
sonPrimosRelativos1 x y =
  null (divisoresPrimos x `intersect` divisoresPrimos y)

-- (divisoresPrimos x) es la lista de los divisores primos de x. Por
-- ejemplo,
--    divisoresPrimos 600  ==  [2,2,2,3,5,5]
divisoresPrimos :: Int -> [Int]
divisoresPrimos 1 = []
divisoresPrimos x =
  y : divisoresPrimos (x `div` y)
  where y = menorDivisorPrimo x

-- (menorDivisorPrimo x) es el menor divisor primo de x. Por ejemplo,
--    menorDivisorPrimo 15  ==  3
--    menorDivisorPrimo 11  ==  11
menorDivisorPrimo :: Int -> Int
menorDivisorPrimo x =
  head [y | y <- [2..], x `mod` y == 0]

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

primosRelativos2 :: [Int] -> Bool
primosRelativos2 []     = True
primosRelativos2 (x:xs) =
  all (sonPrimosRelativos1 x) xs && primosRelativos2 xs

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

primosRelativos3 :: [Int] -> Bool
primosRelativos3 []     = True
primosRelativos3 (x:xs) =
  all (sonPrimosRelativos2 x) xs && primosRelativos3 xs

sonPrimosRelativos2 :: Int -> Int -> Bool
sonPrimosRelativos2 x y =
  null (primeFactors x `intersect` primeFactors y)

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

primosRelativos4 :: [Int] -> Bool
primosRelativos4 []     = True
primosRelativos4 (x:xs) =
  all (sonPrimosRelativos3 x) xs && primosRelativos4 xs

sonPrimosRelativos3 :: Int -> Int -> Bool
sonPrimosRelativos3 x y =
  S.fromList (primeFactors x) `S.disjoint` S.fromList (primeFactors y)

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

primosRelativos5 :: [Int] -> Bool
primosRelativos5 []     = True
primosRelativos5 (x:xs) =
  all (sonPrimosRelativos5 x) xs && primosRelativos5 xs

sonPrimosRelativos5 :: Int -> Int -> Bool
sonPrimosRelativos5 x y =
  gcd x y == 1

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

-- La propiedad es
prop_primosRelativos :: [Positive Int] -> Bool
prop_primosRelativos xs =
  all (== primosRelativos1 ys)
      [primosRelativos2 ys,
       primosRelativos3 ys,
       primosRelativos4 ys,
       primosRelativos5 ys]
  where ys = getPositive <$> xs

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

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

-- La comparación es
--    λ> primosRelativos1 (take 120 primes)
--    True
--    (1.92 secs, 869,909,416 bytes)
--    λ> primosRelativos2 (take 120 primes)
--    True
--    (1.99 secs, 869,045,656 bytes)
--    λ> primosRelativos3 (take 120 primes)
--    True
--    (0.09 secs, 221,183,200 bytes)
--
--    λ> primosRelativos3 (take 600 primes)
--    True
--    (2.62 secs, 11,196,690,856 bytes)
--    λ> primosRelativos4 (take 600 primes)
--    True
--    (2.66 secs, 11,190,940,456 bytes)
--    λ> primosRelativos5 (take 600 primes)
--    True
--    (0.14 secs, 123,673,648 bytes)

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

import Test.QuickCheck

import Data.List (delete, intersect)

import Data.Numbers.Primes (primeFactors, primes)

import qualified Data.Set as S (disjoint, fromList)

-- 1ª solución

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

primosRelativos1 :: [Int] -> Bool

primosRelativos1 [] = True

primosRelativos1 (x:xs) =

and [sonPrimosRelativos1 x y | y <- xs] && primosRelativos1 xs

-- (sonPrimosRelativos x y) se verifica si x e y son primos

-- relativos. Por ejemplo,

-- sonPrimosRelativos1 6 35 == True

-- sonPrimosRelativos1 6 27 == False

sonPrimosRelativos1 :: Int -> Int -> Bool

sonPrimosRelativos1 x y =

null (divisoresPrimos x `intersect` divisoresPrimos y)

-- (divisoresPrimos x) es la lista de los divisores primos de x. Por

-- ejemplo,

-- divisoresPrimos 600 == [2,2,2,3,5,5]

divisoresPrimos :: Int -> [Int]

divisoresPrimos 1 = []

divisoresPrimos x =

y : divisoresPrimos (x `div` y)

where y = menorDivisorPrimo x

-- (menorDivisorPrimo x) es el menor divisor primo de x. Por ejemplo,

-- menorDivisorPrimo 15 == 3

-- menorDivisorPrimo 11 == 11

menorDivisorPrimo :: Int -> Int

menorDivisorPrimo x =

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

-- 2ª solución

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

primosRelativos2 :: [Int] -> Bool

primosRelativos2 [] = True

primosRelativos2 (x:xs) =

all (sonPrimosRelativos1 x) xs && primosRelativos2 xs

-- 3ª solución

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

primosRelativos3 :: [Int] -> Bool

primosRelativos3 [] = True

primosRelativos3 (x:xs) =

all (sonPrimosRelativos2 x) xs && primosRelativos3 xs

sonPrimosRelativos2 :: Int -> Int -> Bool

sonPrimosRelativos2 x y =

null (primeFactors x `intersect` primeFactors y)

-- 4ª solución

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

primosRelativos4 :: [Int] -> Bool

primosRelativos4 [] = True

primosRelativos4 (x:xs) =

all (sonPrimosRelativos3 x) xs && primosRelativos4 xs

sonPrimosRelativos3 :: Int -> Int -> Bool

sonPrimosRelativos3 x y =

S.fromList (primeFactors x) `S.disjoint` S.fromList (primeFactors y)

-- 5ª solución

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

primosRelativos5 :: [Int] -> Bool

primosRelativos5 [] = True

primosRelativos5 (x:xs) =

all (sonPrimosRelativos5 x) xs && primosRelativos5 xs

sonPrimosRelativos5 :: Int -> Int -> Bool

sonPrimosRelativos5 x y =

gcd x y == 1

-- Comprobación de equivalencia

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

-- La propiedad es

prop_primosRelativos :: [Positive Int] -> Bool

prop_primosRelativos xs =

all (== primosRelativos1 ys)

[primosRelativos2 ys,

primosRelativos3 ys,

primosRelativos4 ys,

primosRelativos5 ys]

where ys = getPositive <$> xs

-- La comprobación es

-- λ> quickCheck prop_primosRelativos

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

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

-- La comparación es

-- λ> primosRelativos1 (take 120 primes)

-- True

-- (1.92 secs, 869,909,416 bytes)

-- λ> primosRelativos2 (take 120 primes)

-- True

-- (1.99 secs, 869,045,656 bytes)

-- λ> primosRelativos3 (take 120 primes)

-- True

-- (0.09 secs, 221,183,200 bytes)

-- λ> primosRelativos3 (take 600 primes)

-- True

-- (2.62 secs, 11,196,690,856 bytes)

-- λ> primosRelativos4 (take 600 primes)

-- True

-- (2.66 secs, 11,190,940,456 bytes)

-- λ> primosRelativos5 (take 600 primes)

-- True

-- (0.14 secs, 123,673,648 bytes)

El código se encuentra en GitHub.

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

Nuevas soluciones

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

La sucesión ECG

PorJosé A. Alonso 1-junio-20202-enero-2021

La sucesión ECG estás definida por a(1) = 1, a(2) = 2 y, para n >= 3, a(n) es el menor natural que aún no está en la sucesión tal que a(n) tiene algún divisor común con a(n-1).

Los primeros términos de la sucesión son 1, 2, 4, 6, 3, 9, 12, 8, 10, 5, 15, …

Al dibujar su gráfica, se parece a la de los electrocardiogramas (abreviadamente, ECG). Por ello, la sucesión se conoce como la sucesión ECG.

Definir las funciones

   sucECG :: [Integer]
   graficaSucECG :: Int -> IO ()

1 2	sucECG :: [Integer] graficaSucECG :: Int -> IO ()

tales que

sucECG es la lista de los términos de la sucesión ECG. Por ejemplo,

     λ> take 20 sucECG
     [1,2,4,6,3,9,12,8,10,5,15,18,14,7,21,24,16,20,22,11]
     λ> sucECG !! 6000
     6237

λ> take 20 sucECG

[1,2,4,6,3,9,12,8,10,5,15,18,14,7,21,24,16,20,22,11]

λ> sucECG !! 6000

6237

(graficaSucECG n) dibuja la gráfica de los n primeros términos de la sucesión ECG. Por ejemplo, (graficaSucECG 160) dibuja

Soluciones

import Data.List (delete)
import Graphics.Gnuplot.Simple

sucECG :: [Integer]
sucECG = 1 : ecg 2 [2..]
  where ecg x zs = f zs
          where f (y:ys) | gcd x y > 1 = y : ecg y (delete y zs)
                         | otherwise   = f ys

graficaSucECG :: Int -> IO ()
graficaSucECG n =
  plotList [ Key Nothing
           , PNG "La_sucesion_ECG.png" 
           ]
           (take n sucECG)

import Data.List (delete)

import Graphics.Gnuplot.Simple

sucECG :: [Integer]

sucECG = 1 : ecg 2 [2..]

where ecg x zs = f zs

where f (y:ys) | gcd x y > 1 = y : ecg y (delete y zs)

| otherwise = f ys

graficaSucECG :: Int -> IO ()

graficaSucECG n =

plotList [ Key Nothing

, PNG "La_sucesion_ECG.png"

]

(take n sucECG)

Conjetura de las familias estables por uniones

PorJosé A. Alonso 24-abril-20201-mayo-2020

La conjetura de las familias estables por uniones fue planteada por Péter Frankl en 1979 y aún sigue abierta.

Una familia de conjuntos es estable por uniones si la unión de dos conjuntos cualesquiera de la familia pertenece a la familia. Por ejemplo, {∅, {1}, {2}, {1,2}, {1,3}, {1,2,3}} es estable por uniones; pero {{1}, {2}, {1,3}, {1,2,3}} no lo es.

La conjetura afirma que toda familia no vacía estable por uniones y distinta de {∅} posee algún elemento que pertenece al menos a la mitad de los conjuntos de la familia.

Definir las funciones

   esEstable :: Ord a => Set (Set a) -> Bool
   familiasEstables :: Ord a => Set a -> Set (Set (Set a))
   mayoritarios :: Ord a => Set (Set a) -> [a]
   conjeturaFrankl :: Int -> Bool

esEstable :: Ord a => Set (Set a) -> Bool

familiasEstables :: Ord a => Set a -> Set (Set (Set a))

mayoritarios :: Ord a => Set (Set a) -> [a]

conjeturaFrankl :: Int -> Bool

tales que

(esEstable f) se verifica si la familia f es estable por uniones. Por ejemplo,

     λ> esEstable (fromList [empty, fromList [1,2], fromList [1..5]])
     True
     λ> esEstable (fromList [empty, fromList [1,7], fromList [1..5]])
     False
     λ> esEstable (fromList [fromList [1,2], singleton 3, fromList [1..3]])
     True

λ> esEstable (fromList [empty, fromList [1,2], fromList [1..5]])

True

λ> esEstable (fromList [empty, fromList [1,7], fromList [1..5]])

False

λ> esEstable (fromList [fromList [1,2], singleton 3, fromList [1..3]])

True

(familiasEstables c) es el conjunto de las familias estables por uniones formadas por elementos del conjunto c. Por ejemplo,

     λ> familiasEstables (fromList [1..2])
     fromList
       [ fromList []
       , fromList [fromList []]
       , fromList [fromList [],fromList [1]]
       , fromList [fromList [],fromList [1],fromList [1,2]],
         fromList [fromList [],fromList [1],fromList [1,2],fromList [2]]
       , fromList [fromList [],fromList [1,2]]
       , fromList [fromList [],fromList [1,2],fromList [2]]
       , fromList [fromList [],fromList [2]]
       , fromList [fromList [1]]
       , fromList [fromList [1],fromList [1,2]]
       , fromList [fromList [1],fromList [1,2],fromList [2]]
       , fromList [fromList [1,2]]
       , fromList [fromList [1,2],fromList [2]]
       , fromList [fromList [2]]]
     λ> size (familiasEstables (fromList [1,2]))
     14
     λ> size (familiasEstables (fromList [1..3]))
     122
     λ> size (familiasEstables (fromList [1..4]))
     4960

λ> familiasEstables (fromList [1..2])

fromList

[ fromList []

, fromList [fromList []]

, fromList [fromList [],fromList [1]]

, fromList [fromList [],fromList [1],fromList [1,2]],

fromList [fromList [],fromList [1],fromList [1,2],fromList [2]]

, fromList [fromList [],fromList [1,2]]

, fromList [fromList [],fromList [1,2],fromList [2]]

, fromList [fromList [],fromList [2]]

, fromList [fromList [1]]

, fromList [fromList [1],fromList [1,2]]

, fromList [fromList [1],fromList [1,2],fromList [2]]

, fromList [fromList [1,2]]

, fromList [fromList [1,2],fromList [2]]

, fromList [fromList [2]]]

λ> size (familiasEstables (fromList [1,2]))

λ> size (familiasEstables (fromList [1..3]))

122

λ> size (familiasEstables (fromList [1..4]))

4960

(mayoritarios f) es la lista de elementos que pertenecen al menos a la mitad de los conjuntos de la familia f. Por ejemplo,

     mayoritarios (fromList [empty, fromList [1,3], fromList [3,5]]) == [3]
     mayoritarios (fromList [empty, fromList [1,3], fromList [4,5]]) == []

1 2	mayoritarios (fromList [empty, fromList [1,3], fromList [3,5]]) == [3] mayoritarios (fromList [empty, fromList [1,3], fromList [4,5]]) == []

(conjeturaFrankl n) se verifica si para toda familia f formada por elementos del conjunto {1,2,…,n} no vacía, estable por uniones y distinta de {∅} posee algún elemento que pertenece al menos a la mitad de los conjuntos de f. Por ejemplo.

     conjeturaFrankl 2  ==  True
     conjeturaFrankl 3  ==  True
     conjeturaFrankl 4  ==  True

conjeturaFrankl 2 == True

conjeturaFrankl 3 == True

conjeturaFrankl 4 == True

Soluciones

import Data.Set  as S ( Set
                      , delete
                      , deleteFindMin
                      , empty
                      , filter
                      , fromList
                      , insert
                      , map
                      , member
                      , null
                      , singleton
                      , size
                      , toList
                      , union
                      , unions
                      )
import Data.List as L ( filter
                      , null
                      )

esEstable :: Ord a => Set (Set a) -> Bool
esEstable xss =
  and [ys `S.union` zs `member` xss | (ys,yss) <- selecciones xss
                                    , zs <- toList yss]

-- (seleccciones xs) es la lista de los pares formada por un elemento de
-- xs y los restantes elementos. Por ejemplo,
--    λ> selecciones (fromList [3,2,5])
--    [(2,fromList [3,5]),(3,fromList [2,5]),(5,fromList [2,3])]
selecciones :: Ord a => Set a -> [(a,Set a)]
selecciones xs =
  [(x,delete x xs) | x <- toList xs] 

familiasEstables :: Ord a => Set a -> Set (Set (Set a))
familiasEstables xss =
  S.filter esEstable (familias xss)

-- (familias c) es la familia formadas con elementos de c. Por ejemplo,
--    λ> mapM_ print (familias (fromList [1,2]))
--    fromList []
--    fromList [fromList []]
--    fromList [fromList [],fromList [1]]
--    fromList [fromList [],fromList [1],fromList [1,2]]
--    fromList [fromList [],fromList [1],fromList [1,2],fromList [2]]
--    fromList [fromList [],fromList [1],fromList [2]]
--    fromList [fromList [],fromList [1,2]]
--    fromList [fromList [],fromList [1,2],fromList [2]]
--    fromList [fromList [],fromList [2]]
--    fromList [fromList [1]]
--    fromList [fromList [1],fromList [1,2]]
--    fromList [fromList [1],fromList [1,2],fromList [2]]
--    fromList [fromList [1],fromList [2]]
--    fromList [fromList [1,2]]
--    fromList [fromList [1,2],fromList [2]]
--    fromList [fromList [2]]
--    λ> size (familias (fromList [1,2]))
--    16
--    λ> size (familias (fromList [1,2,3]))
--    256
--    λ> size (familias (fromList [1,2,3,4]))
--    65536
familias :: Ord a => Set a -> Set (Set (Set a))
familias c =
  subconjuntos (subconjuntos c)

-- (subconjuntos c) es el conjunto de los subconjuntos de c. Por ejemplo,
--    λ> mapM_ print (subconjuntos (fromList [1,2,3]))
--    fromList []
--    fromList [1]
--    fromList [1,2]
--    fromList [1,2,3]
--    fromList [1,3]
--    fromList [2]
--    fromList [2,3]
--    fromList [3]
subconjuntos :: Ord a => Set a -> Set (Set a)
subconjuntos c
  | S.null c  = singleton empty
  | otherwise = S.map (insert x) sr `union` sr
  where (x,rc) = deleteFindMin c
        sr     = subconjuntos rc

-- (elementosFamilia f) es el conjunto de los elementos de los elementos
-- de la familia f. Por ejemplo, 
--    λ> elementosFamilia (fromList [empty, fromList [1,2], fromList [2,5]])
--    fromList [1,2,5]
elementosFamilia :: Ord a => Set (Set a) -> Set a
elementosFamilia = unions . toList

-- (nOcurrencias f x) es el número de conjuntos de la familia f a los
-- que pertenece el elemento x. Por ejemplo,
--    nOcurrencias (fromList [empty, fromList [1,3], fromList [3,5]]) 3 == 2
--    nOcurrencias (fromList [empty, fromList [1,3], fromList [3,5]]) 4 == 0
--    nOcurrencias (fromList [empty, fromList [1,3], fromList [3,5]]) 5 == 1
nOcurrencias :: Ord a => Set (Set a) -> a -> Int
nOcurrencias f x =
  length (L.filter (x `member`) (toList f))

mayoritarios :: Ord a => Set (Set a) -> [a]
mayoritarios f =
  [x | x <- toList (elementosFamilia f)
     , nOcurrencias f x >= n]
  where n = (1 + size f) `div` 2

conjeturaFrankl :: Int -> Bool
conjeturaFrankl n =
  and [ not (L.null (mayoritarios f))
      | f <- fs
      , f /= fromList []
      , f /= fromList [empty]]
  where fs = toList (familiasEstables (fromList [1..n]))


-- conjeturaFrankl' :: Int -> Bool
conjeturaFrankl' n =
  [f | f <- fs
     , L.null (mayoritarios f)
     , f /= fromList []
     , f /= fromList [empty]]
  where fs = toList (familiasEstables (fromList [1..n]))

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

import Data.Set as S ( Set

, delete

, deleteFindMin

, empty

, filter

, fromList

, insert

, map

, member

, null

, singleton

, size

, toList

, union

, unions

)

import Data.List as L ( filter

, null

)

esEstable :: Ord a => Set (Set a) -> Bool

esEstable xss =

and [ys `S.union` zs `member` xss | (ys,yss) <- selecciones xss

, zs <- toList yss]

-- (seleccciones xs) es la lista de los pares formada por un elemento de

-- xs y los restantes elementos. Por ejemplo,

-- λ> selecciones (fromList [3,2,5])

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

selecciones :: Ord a => Set a -> [(a,Set a)]

selecciones xs =

[(x,delete x xs) | x <- toList xs]

familiasEstables :: Ord a => Set a -> Set (Set (Set a))

familiasEstables xss =

S.filter esEstable (familias xss)

-- (familias c) es la familia formadas con elementos de c. Por ejemplo,

-- λ> mapM_ print (familias (fromList [1,2]))

-- fromList []

-- fromList [fromList []]

-- fromList [fromList [],fromList [1]]

-- fromList [fromList [],fromList [1],fromList [1,2]]

-- fromList [fromList [],fromList [1],fromList [1,2],fromList [2]]

-- fromList [fromList [],fromList [1],fromList [2]]

-- fromList [fromList [],fromList [1,2]]

-- fromList [fromList [],fromList [1,2],fromList [2]]

-- fromList [fromList [],fromList [2]]

-- fromList [fromList [1]]

-- fromList [fromList [1],fromList [1,2]]

-- fromList [fromList [1],fromList [1,2],fromList [2]]

-- fromList [fromList [1],fromList [2]]

-- fromList [fromList [1,2]]

-- fromList [fromList [1,2],fromList [2]]

-- fromList [fromList [2]]

-- λ> size (familias (fromList [1,2]))

-- 16

-- λ> size (familias (fromList [1,2,3]))

-- 256

-- λ> size (familias (fromList [1,2,3,4]))

-- 65536

familias :: Ord a => Set a -> Set (Set (Set a))

familias c =

subconjuntos (subconjuntos c)

-- (subconjuntos c) es el conjunto de los subconjuntos de c. Por ejemplo,

-- λ> mapM_ print (subconjuntos (fromList [1,2,3]))

-- fromList []

-- fromList [1]

-- fromList [1,2]

-- fromList [1,2,3]

-- fromList [1,3]

-- fromList [2]

-- fromList [2,3]

-- fromList [3]

subconjuntos :: Ord a => Set a -> Set (Set a)

subconjuntos c

| S.null c = singleton empty

| otherwise = S.map (insert x) sr `union` sr

where (x,rc) = deleteFindMin c

sr = subconjuntos rc

-- (elementosFamilia f) es el conjunto de los elementos de los elementos

-- de la familia f. Por ejemplo,

-- λ> elementosFamilia (fromList [empty, fromList [1,2], fromList [2,5]])

-- fromList [1,2,5]

elementosFamilia :: Ord a => Set (Set a) -> Set a

elementosFamilia = unions . toList

-- (nOcurrencias f x) es el número de conjuntos de la familia f a los

-- que pertenece el elemento x. Por ejemplo,

-- nOcurrencias (fromList [empty, fromList [1,3], fromList [3,5]]) 3 == 2

-- nOcurrencias (fromList [empty, fromList [1,3], fromList [3,5]]) 4 == 0

-- nOcurrencias (fromList [empty, fromList [1,3], fromList [3,5]]) 5 == 1

nOcurrencias :: Ord a => Set (Set a) -> a -> Int

nOcurrencias f x =

length (L.filter (x `member`) (toList f))

mayoritarios :: Ord a => Set (Set a) -> [a]

mayoritarios f =

[x | x <- toList (elementosFamilia f)

, nOcurrencias f x >= n]

where n = (1 + size f) `div` 2

conjeturaFrankl :: Int -> Bool

conjeturaFrankl n =

and [ not (L.null (mayoritarios f))

| f <- fs

, f /= fromList []

, f /= fromList [empty]]

where fs = toList (familiasEstables (fromList [1..n]))

-- conjeturaFrankl' :: Int -> Bool

conjeturaFrankl' n =

[f | f <- fs

, L.null (mayoritarios f)

, f /= fromList []

, f /= fromList [empty]]

where fs = toList (familiasEstables (fromList [1..n]))

Otras soluciones

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

La mayor potencia de dos no es divisor

PorJosé A. Alonso 7-enero-202014-enero-2020

Para cada número entero positivo n, se define el conjunto

   S(n) = {1, 2, 3, ..., n}

1	S(n) = {1, 2, 3, ..., n}

de los números desde el 1 hasta n.

Definir la función

   mayorPotenciaDeDosEnS :: Integer -> Integer

1	mayorPotenciaDeDosEnS :: Integer -> Integer

tal que (mayorPotenciaDeDosEnS n) es la mayor potencia de 2 en S(n). Por ejemplo,

   mayorPotenciaDeDosEnS 3  ==  2
   mayorPotenciaDeDosEnS 4  ==  4

1 2	mayorPotenciaDeDosEnS 3 == 2 mayorPotenciaDeDosEnS 4 == 4

Comprobar con QuickCheck que la mayor potencia de 2 en S(n) no divide a ningún otro elemento de S(n).

Soluciones

import Data.List (delete)
import Test.QuickCheck

mayorPotenciaDeDosEnS :: Integer -> Integer
mayorPotenciaDeDosEnS n =
  last (takeWhile (<=n) potenciasDeDos)

-- potenciasDeDos es la lista de las potencias de 2. Por ejemplo,
--    take 5 potenciasDeDos  ==  [1,2,4,8,16]
potenciasDeDos :: [Integer]
potenciasDeDos = iterate (*2) 1

-- La propiedad es
prop_mayorPotenciaDeDosEnS :: Integer -> Property
prop_mayorPotenciaDeDosEnS n =
  n > 0 ==> all (x `noDivide`) (delete x [1..n])
  where x = mayorPotenciaDeDosEnS n
        x `noDivide` y = y `mod` x /= 0

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

import Data.List (delete)

import Test.QuickCheck

mayorPotenciaDeDosEnS :: Integer -> Integer

mayorPotenciaDeDosEnS n =

last (takeWhile (<=n) potenciasDeDos)

-- potenciasDeDos es la lista de las potencias de 2. Por ejemplo,

-- take 5 potenciasDeDos == [1,2,4,8,16]

potenciasDeDos :: [Integer]

potenciasDeDos = iterate (*2) 1

-- La propiedad es

prop_mayorPotenciaDeDosEnS :: Integer -> Property

prop_mayorPotenciaDeDosEnS n =

n > 0 ==> all (x `noDivide`) (delete x [1..n])

where x = mayorPotenciaDeDosEnS n

x `noDivide` y = y `mod` x /= 0

-- La comprobación es

-- λ> quickCheck prop_mayorPotenciaDeDosEnS

-- +++ OK, passed 100 tests.

Referencia

Basado en Greatest power of two not divisor de ProofWiki.

Pensamiento

¡Sólo tu figura,
como una centella blanca,
en mi noche oscura.

Antonio Machado

Número de emparejamientos de amigos

PorJosé A. Alonso 30-abril-201919-mayo-2019

El problema del número de emparejamiento de amigos consiste en calcular el número de formas de emparejar n amigos teniendo en cuenta que cada uno puede permanecer soltero o puede ser emparejado con algún otro amigo y que cada amigo puede ser emparejado sólo una vez. Por ejemplo, los 4 posibles emparejamientos de 3 amigos son

   {1}, {2}, {3} 
   {1}, {2, 3} 
   {1, 2}, {3} 
   {1, 3}, {2}

{1}, {2}, {3}

{1}, {2, 3}

{1, 2}, {3}

{1, 3}, {2}

Definir la función

   nEmparejamientos :: Integer -> Integer

1	nEmparejamientos :: Integer -> Integer

tal que (nEmparejamientos n) es el número de formas de emparejar a los n amigos. Por ejemplo,

   nEmparejamientos 2   ==  2
   nEmparejamientos 3   ==  4
   nEmparejamientos 4   ==  10
   nEmparejamientos 10  ==  9496
   nEmparejamientos 30  ==  606917269909048576
   length (show (nEmparejamientos3 (10^4)))  ==  17872

nEmparejamientos 2 == 2

nEmparejamientos 3 == 4

nEmparejamientos 4 == 10

nEmparejamientos 10 == 9496

nEmparejamientos 30 == 606917269909048576

length (show (nEmparejamientos3 (10^4))) == 17872

Soluciones

import Data.List (delete, genericLength)
import Data.Array

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

nEmparejamientos :: Integer -> Integer
nEmparejamientos = genericLength . emparejamientos

emparejamientos :: Integer -> [[[Integer]]]
emparejamientos n = aux [1..n]
  where aux [] = [[]]
        aux (x:xs) = [[x] : ps | ps <- aux xs] ++
                     [[x,y] : ps | y <- xs, ps <- aux (delete y xs)]

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

nEmparejamientos2 :: Integer -> Integer
nEmparejamientos2 0 = 1
nEmparejamientos2 1 = 1
nEmparejamientos2 2 = 2
nEmparejamientos2 n = nEmparejamientos2 (n - 1) + (n - 1) * nEmparejamientos2 (n - 2)

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

nEmparejamientos3 :: Integer -> Integer
nEmparejamientos3 n = (vectorEmparejamientos n) ! n

-- (vectorEmparejamientos n) es el vector con índices de 0 a n tal que el valor
-- de la posición i es el número de formas de emparejar a i amigos. Por ejemplo,
--    λ> vectorEmparejamientos 7
--    array (0,7) [(0,1),(1,1),(2,2),(3,4),(4,10),(5,26),(6,76),(7,232)]
vectorEmparejamientos :: Integer -> Array Integer Integer
vectorEmparejamientos n = v where
  v = array (0,n) [(i,f i) | i <- [0..n]]
  f 0 = 1
  f 1 = 1
  f 2 = 2
  f n = v!(n-1) + (n-1)*v!(n-2)

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

--    λ> nEmparejamientos 12
--    140152
--    (1.81 secs, 280,218,616 bytes)
--    λ> nEmparejamientos2 12
--    140152
--    (0.01 secs, 177,168 bytes)
--    λ> nEmparejamientos3 12
--    140152
--    (0.01 secs, 108,816 bytes)
--    
--    λ> nEmparejamientos2 30
--    606917269909048576
--    (3.97 secs, 449,224,280 bytes)
--    λ> nEmparejamientos3 30
--    606917269909048576
--    (0.01 secs, 135,160 bytes)

import Data.List (delete, genericLength)

import Data.Array

-- 1ª solución

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

nEmparejamientos :: Integer -> Integer

nEmparejamientos = genericLength . emparejamientos

emparejamientos :: Integer -> [[[Integer]]]

emparejamientos n = aux [1..n]

where aux [] = [[]]

aux (x:xs) = [[x] : ps | ps <- aux xs] ++

[[x,y] : ps | y <- xs, ps <- aux (delete y xs)]

-- 2ª solución

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

nEmparejamientos2 :: Integer -> Integer

nEmparejamientos2 0 = 1

nEmparejamientos2 1 = 1

nEmparejamientos2 2 = 2

nEmparejamientos2 n = nEmparejamientos2 (n - 1) + (n - 1) * nEmparejamientos2 (n - 2)

-- 3ª solución

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

nEmparejamientos3 :: Integer -> Integer

nEmparejamientos3 n = (vectorEmparejamientos n) ! n

-- (vectorEmparejamientos n) es el vector con índices de 0 a n tal que el valor

-- de la posición i es el número de formas de emparejar a i amigos. Por ejemplo,

-- λ> vectorEmparejamientos 7

-- array (0,7) [(0,1),(1,1),(2,2),(3,4),(4,10),(5,26),(6,76),(7,232)]

vectorEmparejamientos :: Integer -> Array Integer Integer

vectorEmparejamientos n = v where

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

f 0 = 1

f 1 = 1

f 2 = 2

f n = v!(n-1) + (n-1)*v!(n-2)

-- Comparación de eficiencia

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

-- λ> nEmparejamientos 12

-- 140152

-- (1.81 secs, 280,218,616 bytes)

-- λ> nEmparejamientos2 12

-- 140152

-- (0.01 secs, 177,168 bytes)

-- λ> nEmparejamientos3 12

-- 140152

-- (0.01 secs, 108,816 bytes)

-- λ> nEmparejamientos2 30

-- 606917269909048576

-- (3.97 secs, 449,224,280 bytes)

-- λ> nEmparejamientos3 30

-- 606917269909048576

-- (0.01 secs, 135,160 bytes)

Pensamiento

Toda la imaginería
que no ha brotado del río,
barata bisutería.

Antonio Machado

Emparejamiento de amigos

PorJosé A. Alonso 29-abril-201919-mayo-2019

El problema de emparejamiento de amigos consiste en calcular las formas de emparejar n amigos teniendo en cuenta que cada uno puede permanecer soltero o puede ser emparejado con algún otro amigo y que cada amigo puede ser emparejado sólo una vez. Por ejemplo, los 4 posibles emparejamientos de 3 amigos son

   {1}, {2}, {3} 
   {1}, {2, 3} 
   {1, 2}, {3} 
   {1, 3}, {2}

{1}, {2}, {3}

{1}, {2, 3}

{1, 2}, {3}

{1, 3}, {2}

Definir la función

   emparejamientos :: Integer -> [[[Integer]]]

1	emparejamientos :: Integer -> [[[Integer]]]

tal que (emparejamientos n) es la lista de los posibles emparejamientos de los n amigos (numerados del 1 al n). Por ejemplo,

   λ> emparejamientos 2
   [[[1],[2]],[[1,2]]]
   λ> emparejamientos 3
   [[[1],[2],[3]],[[1],[2,3]],[[1,2],[3]],[[1,3],[2]]]

λ> emparejamientos 2

[[[1],[2]],[[1,2]]]

λ> emparejamientos 3

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

Soluciones

import Data.List (delete)

emparejamientos :: Integer -> [[[Integer]]]
emparejamientos n = aux [1..n]
  where aux [] = [[]]
        aux (x:xs) = [[x] : ps | ps <- aux xs] ++
                     [[x,y] : ps | y <- xs, ps <- aux (delete y xs)]

import Data.List (delete)

emparejamientos :: Integer -> [[[Integer]]]

emparejamientos n = aux [1..n]

where aux [] = [[]]

aux (x:xs) = [[x] : ps | ps <- aux xs] ++

[[x,y] : ps | y <- xs, ps <- aux (delete y xs)]

Pensamiento

Crea el alma sus riberas;
montes de ceniza y plomo,
sotillos de primavera.

Antonio Machado

Conjetura de las familias estables por uniones

PorJosé A. Alonso 5-abril-201925-abril-2021

La conjetura de las familias estables por uniones fue planteada por Péter Frankl en 1979 y aún sigue abierta.

La conjetura afirma que toda familia no vacía estable por uniones y distinta de {∅} posee algún elemento que pertenece al menos a la mitad de los conjuntos de la familia.

Definir las funciones

   esEstable :: Ord a => Set (Set a) -> Bool
   familiasEstables :: Ord a => Set a -> Set (Set (Set a))
   mayoritarios :: Ord a => Set (Set a) -> [a]
   conjeturaFrankl :: Int -> Bool

esEstable :: Ord a => Set (Set a) -> Bool

familiasEstables :: Ord a => Set a -> Set (Set (Set a))

mayoritarios :: Ord a => Set (Set a) -> [a]

conjeturaFrankl :: Int -> Bool

tales que

(esEstable f) se verifica si la familia f es estable por uniones. Por ejemplo,

     λ> esEstable (fromList [empty, fromList [1,2], fromList [1..5]])
     True
     λ> esEstable (fromList [empty, fromList [1,7], fromList [1..5]])
     False
     λ> esEstable (fromList [fromList [1,2], singleton 3, fromList [1..3]])
     True

λ> esEstable (fromList [empty, fromList [1,2], fromList [1..5]])

True

λ> esEstable (fromList [empty, fromList [1,7], fromList [1..5]])

False

λ> esEstable (fromList [fromList [1,2], singleton 3, fromList [1..3]])

True

(familiasEstables c) es el conjunto de las familias estables por uniones formadas por elementos del conjunto c. Por ejemplo,

     λ> familiasEstables (fromList [1..2])
     fromList
       [ fromList []
       , fromList [fromList []]
       , fromList [fromList [],fromList [1]]
       , fromList [fromList [],fromList [1],fromList [1,2]],
         fromList [fromList [],fromList [1],fromList [1,2],fromList [2]]
       , fromList [fromList [],fromList [1,2]]
       , fromList [fromList [],fromList [1,2],fromList [2]]
       , fromList [fromList [],fromList [2]]
       , fromList [fromList [1]]
       , fromList [fromList [1],fromList [1,2]]
       , fromList [fromList [1],fromList [1,2],fromList [2]]
       , fromList [fromList [1,2]]
       , fromList [fromList [1,2],fromList [2]]
       , fromList [fromList [2]]]
     λ> size (familiasEstables (fromList [1,2]))
     14
     λ> size (familiasEstables (fromList [1..3]))
     122
     λ> size (familiasEstables (fromList [1..4]))
     4960

λ> familiasEstables (fromList [1..2])

fromList

[ fromList []

, fromList [fromList []]

, fromList [fromList [],fromList [1]]

, fromList [fromList [],fromList [1],fromList [1,2]],

fromList [fromList [],fromList [1],fromList [1,2],fromList [2]]

, fromList [fromList [],fromList [1,2]]

, fromList [fromList [],fromList [1,2],fromList [2]]

, fromList [fromList [],fromList [2]]

, fromList [fromList [1]]

, fromList [fromList [1],fromList [1,2]]

, fromList [fromList [1],fromList [1,2],fromList [2]]

, fromList [fromList [1,2]]

, fromList [fromList [1,2],fromList [2]]

, fromList [fromList [2]]]

λ> size (familiasEstables (fromList [1,2]))

λ> size (familiasEstables (fromList [1..3]))

122

λ> size (familiasEstables (fromList [1..4]))

4960

(mayoritarios f) es la lista de elementos que pertenecen al menos a la mitad de los conjuntos de la familia f. Por ejemplo,

     mayoritarios (fromList [empty, fromList [1,3], fromList [3,5]]) == [3]
     mayoritarios (fromList [empty, fromList [1,3], fromList [4,5]]) == []

1 2	mayoritarios (fromList [empty, fromList [1,3], fromList [3,5]]) == [3] mayoritarios (fromList [empty, fromList [1,3], fromList [4,5]]) == []

(conjeturaFrankl n) se verifica si para toda familia f formada por elementos del conjunto {1,2,…,n} no vacía, estable por uniones y distinta de {∅} posee algún elemento que pertenece al menos a la mitad de los conjuntos de f. Por ejemplo.

     conjeturaFrankl 2  ==  True
     conjeturaFrankl 3  ==  True
     conjeturaFrankl 4  ==  True

conjeturaFrankl 2 == True

conjeturaFrankl 3 == True

conjeturaFrankl 4 == True

Soluciones

import Data.Set  as S ( Set
                      , delete
                      , deleteFindMin
                      , empty
                      , filter
                      , fromList
                      , insert
                      , map
                      , member
                      , null
                      , singleton
                      , size
                      , toList
                      , union
                      , unions
                      )
import Data.List as L ( filter
                      , null
                      )

esEstable :: Ord a => Set (Set a) -> Bool
esEstable xss =
  and [ys `S.union` zs `member` xss | (ys,yss) <- selecciones xss
                                    , zs <- toList yss]

-- (seleccciones xs) es la lista de los pares formada por un elemento de
-- xs y los restantes elementos. Por ejemplo,
--    λ> selecciones (fromList [3,2,5])
--    [(2,fromList [3,5]),(3,fromList [2,5]),(5,fromList [2,3])]
selecciones :: Ord a => Set a -> [(a,Set a)]
selecciones xs =
  [(x,delete x xs) | x <- toList xs] 

familiasEstables :: Ord a => Set a -> Set (Set (Set a))
familiasEstables xss =
  S.filter esEstable (familias xss)

-- (familias c) es la familia formadas con elementos de c. Por ejemplo,
--    λ> mapM_ print (familias (fromList [1,2]))
--    fromList []
--    fromList [fromList []]
--    fromList [fromList [],fromList [1]]
--    fromList [fromList [],fromList [1],fromList [1,2]]
--    fromList [fromList [],fromList [1],fromList [1,2],fromList [2]]
--    fromList [fromList [],fromList [1],fromList [2]]
--    fromList [fromList [],fromList [1,2]]
--    fromList [fromList [],fromList [1,2],fromList [2]]
--    fromList [fromList [],fromList [2]]
--    fromList [fromList [1]]
--    fromList [fromList [1],fromList [1,2]]
--    fromList [fromList [1],fromList [1,2],fromList [2]]
--    fromList [fromList [1],fromList [2]]
--    fromList [fromList [1,2]]
--    fromList [fromList [1,2],fromList [2]]
--    fromList [fromList [2]]
--    λ> size (familias (fromList [1,2]))
--    16
--    λ> size (familias (fromList [1,2,3]))
--    256
--    λ> size (familias (fromList [1,2,3,4]))
--    65536
familias :: Ord a => Set a -> Set (Set (Set a))
familias c =
  subconjuntos (subconjuntos c)

-- (subconjuntos c) es el conjunto de los subconjuntos de c. Por ejemplo,
--    λ> mapM_ print (subconjuntos (fromList [1,2,3]))
--    fromList []
--    fromList [1]
--    fromList [1,2]
--    fromList [1,2,3]
--    fromList [1,3]
--    fromList [2]
--    fromList [2,3]
--    fromList [3]
subconjuntos :: Ord a => Set a -> Set (Set a)
subconjuntos c
  | S.null c  = singleton empty
  | otherwise = S.map (insert x) sr `union` sr
  where (x,rc) = deleteFindMin c
        sr     = subconjuntos rc

-- (elementosFamilia f) es el conjunto de los elementos de los elementos
-- de la familia f. Por ejemplo, 
--    λ> elementosFamilia (fromList [empty, fromList [1,2], fromList [2,5]])
--    fromList [1,2,5]
elementosFamilia :: Ord a => Set (Set a) -> Set a
elementosFamilia = unions . toList

-- (nOcurrencias f x) es el número de conjuntos de la familia f a los
-- que pertenece el elemento x. Por ejemplo,
--    nOcurrencias (fromList [empty, fromList [1,3], fromList [3,5]]) 3 == 2
--    nOcurrencias (fromList [empty, fromList [1,3], fromList [3,5]]) 4 == 0
--    nOcurrencias (fromList [empty, fromList [1,3], fromList [3,5]]) 5 == 1
nOcurrencias :: Ord a => Set (Set a) -> a -> Int
nOcurrencias f x =
  length (L.filter (x `member`) (toList f))

mayoritarios :: Ord a => Set (Set a) -> [a]
mayoritarios f =
  [x | x <- toList (elementosFamilia f)
     , nOcurrencias f x >= n]
  where n = (1 + size f) `div` 2

conjeturaFrankl :: Int -> Bool
conjeturaFrankl n =
  and [ not (L.null (mayoritarios f))
      | f <- fs
      , f /= fromList []
      , f /= fromList [empty]]
  where fs = toList (familiasEstables (fromList [1..n]))


-- conjeturaFrankl' :: Int -> Bool
conjeturaFrankl' n =
  [f | f <- fs
     , L.null (mayoritarios f)
     , f /= fromList []
     , f /= fromList [empty]]
  where fs = toList (familiasEstables (fromList [1..n]))

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

import Data.Set as S ( Set

, delete

, deleteFindMin

, empty

, filter

, fromList

, insert

, map

, member

, null

, singleton

, size

, toList

, union

, unions

)

import Data.List as L ( filter

, null

)

esEstable :: Ord a => Set (Set a) -> Bool

esEstable xss =

and [ys `S.union` zs `member` xss | (ys,yss) <- selecciones xss

, zs <- toList yss]

-- (seleccciones xs) es la lista de los pares formada por un elemento de

-- xs y los restantes elementos. Por ejemplo,

-- λ> selecciones (fromList [3,2,5])

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

selecciones :: Ord a => Set a -> [(a,Set a)]

selecciones xs =

[(x,delete x xs) | x <- toList xs]

familiasEstables :: Ord a => Set a -> Set (Set (Set a))

familiasEstables xss =

S.filter esEstable (familias xss)

-- (familias c) es la familia formadas con elementos de c. Por ejemplo,

-- λ> mapM_ print (familias (fromList [1,2]))

-- fromList []

-- fromList [fromList []]

-- fromList [fromList [],fromList [1]]

-- fromList [fromList [],fromList [1],fromList [1,2]]

-- fromList [fromList [],fromList [1],fromList [1,2],fromList [2]]

-- fromList [fromList [],fromList [1],fromList [2]]

-- fromList [fromList [],fromList [1,2]]

-- fromList [fromList [],fromList [1,2],fromList [2]]

-- fromList [fromList [],fromList [2]]

-- fromList [fromList [1]]

-- fromList [fromList [1],fromList [1,2]]

-- fromList [fromList [1],fromList [1,2],fromList [2]]

-- fromList [fromList [1],fromList [2]]

-- fromList [fromList [1,2]]

-- fromList [fromList [1,2],fromList [2]]

-- fromList [fromList [2]]

-- λ> size (familias (fromList [1,2]))

-- 16

-- λ> size (familias (fromList [1,2,3]))

-- 256

-- λ> size (familias (fromList [1,2,3,4]))

-- 65536

familias :: Ord a => Set a -> Set (Set (Set a))

familias c =

subconjuntos (subconjuntos c)

-- (subconjuntos c) es el conjunto de los subconjuntos de c. Por ejemplo,

-- λ> mapM_ print (subconjuntos (fromList [1,2,3]))

-- fromList []

-- fromList [1]

-- fromList [1,2]

-- fromList [1,2,3]

-- fromList [1,3]

-- fromList [2]

-- fromList [2,3]

-- fromList [3]

subconjuntos :: Ord a => Set a -> Set (Set a)

subconjuntos c

| S.null c = singleton empty

| otherwise = S.map (insert x) sr `union` sr

where (x,rc) = deleteFindMin c

sr = subconjuntos rc

-- (elementosFamilia f) es el conjunto de los elementos de los elementos

-- de la familia f. Por ejemplo,

-- λ> elementosFamilia (fromList [empty, fromList [1,2], fromList [2,5]])

-- fromList [1,2,5]

elementosFamilia :: Ord a => Set (Set a) -> Set a

elementosFamilia = unions . toList

-- (nOcurrencias f x) es el número de conjuntos de la familia f a los

-- que pertenece el elemento x. Por ejemplo,

-- nOcurrencias (fromList [empty, fromList [1,3], fromList [3,5]]) 3 == 2

-- nOcurrencias (fromList [empty, fromList [1,3], fromList [3,5]]) 4 == 0

-- nOcurrencias (fromList [empty, fromList [1,3], fromList [3,5]]) 5 == 1

nOcurrencias :: Ord a => Set (Set a) -> a -> Int

nOcurrencias f x =

length (L.filter (x `member`) (toList f))

mayoritarios :: Ord a => Set (Set a) -> [a]

mayoritarios f =

[x | x <- toList (elementosFamilia f)

, nOcurrencias f x >= n]

where n = (1 + size f) `div` 2

conjeturaFrankl :: Int -> Bool

conjeturaFrankl n =

and [ not (L.null (mayoritarios f))

| f <- fs

, f /= fromList []

, f /= fromList [empty]]

where fs = toList (familiasEstables (fromList [1..n]))

-- conjeturaFrankl' :: Int -> Bool

conjeturaFrankl' n =

[f | f <- fs

, L.null (mayoritarios f)

, f /= fromList []

, f /= fromList [empty]]

where fs = toList (familiasEstables (fromList [1..n]))

Pensamiento

Pero tampoco es razón
desdeñar
consejo que es confesión.

Antonio Machado

La sucesión ECG

PorJosé A. Alonso 21-marzo-201925-abril-2021

La sucesión ECG estás definida por a(1) = 1, a(2) = 2 y, para n >= 3, a(n) es el menor natural que aún no está en la sucesión tal que a(n) tiene algún divisor común con a(n-1).

Los primeros términos de la sucesión son 1, 2, 4, 6, 3, 9, 12, 8, 10, 5, 15, …

Al dibujar su gráfica, se parece a la de los electrocardiogramas (abreviadamente, ECG). Por ello, la sucesión se conoce como la sucesión ECG.

Definir las funciones

   sucECG :: [Integer]
   graficaSucECG :: Int -> IO ()

1 2	sucECG :: [Integer] graficaSucECG :: Int -> IO ()

tales que

sucECG es la lista de los términos de la sucesión ECG. Por ejemplo,

     λ> take 20 sucECG
     [1,2,4,6,3,9,12,8,10,5,15,18,14,7,21,24,16,20,22,11]
     λ> sucECG !! 6000
     6237

λ> take 20 sucECG

[1,2,4,6,3,9,12,8,10,5,15,18,14,7,21,24,16,20,22,11]

λ> sucECG !! 6000

6237

(graficaSucECG n) dibuja la gráfica de los n primeros términos de la sucesión ECG. Por ejemplo, (graficaSucECG 160) dibuja

Soluciones

import Data.List (delete)
import Graphics.Gnuplot.Simple

sucECG :: [Integer]
sucECG = 1 : ecg 2 [2..]
  where ecg x zs = f zs
          where f (y:ys) | gcd x y > 1 = y : ecg y (delete y zs)
                         | otherwise   = f ys

graficaSucECG :: Int -> IO ()
graficaSucECG n =
  plotList [ Key Nothing
           , PNG "La_sucesion_ECG.png" 
           ]
           (take n sucECG)

import Data.List (delete)

import Graphics.Gnuplot.Simple

sucECG :: [Integer]

sucECG = 1 : ecg 2 [2..]

where ecg x zs = f zs

where f (y:ys) | gcd x y > 1 = y : ecg y (delete y zs)

| otherwise = f ys

graficaSucECG :: Int -> IO ()

graficaSucECG n =

plotList [ Key Nothing

, PNG "La_sucesion_ECG.png"

]

(take n sucECG)

Pensamiento

Algunos desesperados
sólo se curan con soga;
otros, con siete palabras:
la fe se ha puesto de moda.

Antonio Machado

Árbol de subconjuntos

PorJosé A. Alonso 28-diciembre-20184-enero-2019

Se dice que A es un subconjunto maximal de B si A ⊂ B y no existe ningún C tal que A ⊂ C y C ⊂ B. Por ejemplo, {2,5} es un subconjunto maximal de {2,3,5], pero {3] no lo es.

El árbol de los subconjuntos de un conjunto A es el árbol que tiene como raíz el conjunto A y cada nodo tiene como hijos sus subconjuntos maximales. Por ejemplo, el árbol de subconjuntos de [2,3,5] es

          [2, 3, 5]
          /   |  \
         /    |   \  
        /     |    \   
       /      |     \
      /       |      \
    [5,3]   [2,3]   [2,5]  
    /  \    /  \    /  \  
   [3] [5] [3] [2] [5] [2]
    |   |   |   |   |   | 
   [ ] [ ] [ ] [ ] [ ] [ ]

[2, 3, 5]

/ | \

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

/ \ / \ / \

[3] [5] [3] [2] [5] [2]

| | | | | |

[ ] [ ] [ ] [ ] [ ] [ ]

Usando el tipo de dato

   data Arbol = N [Integer] [Arbol]
     deriving (Eq, Show)

1 2	data Arbol = N [Integer] [Arbol] deriving (Eq, Show)

el árbol anterior se representa por

   N [2,5,3]
     [N [5,3]
        [N [3]
           [N [] []],
         N [5]
           [N [] []]],
      N [2,3]
        [N [3]
           [N [] []],
         N [2]
           [N [] []]],
      N [2,5]
        [N [5]
           [N [] []],
         N [2]
           [N [] []]]]

N [2,5,3]

[N [5,3]

[N [3]

[N [] []],

N [5]

[N [] []]],

N [2,3]

[N [3]

[N [] []],

N [2]

[N [] []]],

N [2,5]

[N [5]

[N [] []],

N [2]

[N [] []]]]

Definir las funciones

   arbolSubconjuntos :: [Int] -> Arbol 
   nOcurrenciasArbolSubconjuntos :: [Int] -> [Int] -> Int

1 2	arbolSubconjuntos :: [Int] -> Arbol nOcurrenciasArbolSubconjuntos :: [Int] -> [Int] -> Int

tales que

(arbolSubconjuntos x) es el árbol de los subconjuntos de xs. Por ejemplo,

     λ> arbolSubconjuntos [2,5,3]
     N [2,5,3] [N [5,3] [N [3] [N [] []],N [5] [N [] []]],
                N [2,3] [N [3] [N [] []],N [2] [N [] []]],
                N [2,5] [N [5] [N [] []],N [2] [N [] []]]]

λ> arbolSubconjuntos [2,5,3]

N [2,5,3] [N [5,3] [N [3] [N [] []],N [5] [N [] []]],

N [2,3] [N [3] [N [] []],N [2] [N [] []]],

N [2,5] [N [5] [N [] []],N [2] [N [] []]]]

(nOcurrenciasArbolSubconjuntos xs ys) es el número de veces que aparece el conjunto xs en el árbol de los subconjuntos de ys. Por ejemplo,

     nOcurrenciasArbolSubconjuntos []      [2,5,3]  ==  6
     nOcurrenciasArbolSubconjuntos [3]     [2,5,3]  ==  2
     nOcurrenciasArbolSubconjuntos [3,5]   [2,5,3]  ==  1
     nOcurrenciasArbolSubconjuntos [3,5,2] [2,5,3]  ==  1

nOcurrenciasArbolSubconjuntos [] [2,5,3] == 6

nOcurrenciasArbolSubconjuntos [3] [2,5,3] == 2

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

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

Comprobar con QuickChek que, para todo entero positivo n, el número de ocurrencia de un subconjunto xs de [1..n] en el árbol de los subconjuntos de [1..n] es el factorial de n-k (donde k es el número de elementos de xs).

Soluciones

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

data Arbol = N [Int] [Arbol]
  deriving (Eq, Show)

arbolSubconjuntos :: [Int] -> Arbol 
arbolSubconjuntos xs =
  N xs (map arbolSubconjuntos (subconjuntosMaximales xs))

-- (subconjuntosMaximales xs) es la lista de los subconjuntos maximales
-- de xs. Por ejemplo,
--    subconjuntosMaximales [2,5,3]  ==  [[5,3],[2,3],[2,5]]
subconjuntosMaximales :: [Int] -> [[Int]]
subconjuntosMaximales xs =
  [delete x xs | x <- xs]

-- Definición de nOcurrenciasArbolSubconjuntos
-- ===========================================

nOcurrenciasArbolSubconjuntos :: [Int] -> [Int] -> Int
nOcurrenciasArbolSubconjuntos xs ys =
  nOcurrencias xs (arbolSubconjuntos ys)

-- (nOcurrencias x a) es el número de veces que aparece x en el árbol
-- a. Por ejemplo,
--    nOcurrencias 3 (arbolSubconjuntos 30)  ==  2
nOcurrencias :: [Int] -> Arbol -> Int
nOcurrencias xs (N ys [])
  | conjunto xs == conjunto ys  = 1
  | otherwise                   = 0
nOcurrencias xs (N ys zs)
  | conjunto xs == conjunto ys = 1 + sum [nOcurrencias xs z | z <- zs]
  | otherwise                  = sum [nOcurrencias xs z | z <- zs]

-- (conjunto xs) es el conjunto ordenado correspondiente a xs. Por
-- ejemplo, 
--    conjunto [3,2,5,2,3,7,2]  ==  [2,3,5,7]
conjunto :: [Int] -> [Int]
conjunto = nub . sort

-- La propiedad es
prop_nOcurrencias :: (Positive Int) -> [Int] -> Bool
prop_nOcurrencias (Positive n) xs =
  nOcurrenciasArbolSubconjuntos ys [1..n] == factorial (n-k)
  where ys = nub [1 + x `mod` n | x <- xs]
        k  = length ys
        factorial m = product [1..m]

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

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

import Test.QuickCheck

data Arbol = N [Int] [Arbol]

deriving (Eq, Show)

arbolSubconjuntos :: [Int] -> Arbol

arbolSubconjuntos xs =

N xs (map arbolSubconjuntos (subconjuntosMaximales xs))

-- (subconjuntosMaximales xs) es la lista de los subconjuntos maximales

-- de xs. Por ejemplo,

-- subconjuntosMaximales [2,5,3] == [[5,3],[2,3],[2,5]]

subconjuntosMaximales :: [Int] -> [[Int]]

subconjuntosMaximales xs =

[delete x xs | x <- xs]

-- Definición de nOcurrenciasArbolSubconjuntos

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

nOcurrenciasArbolSubconjuntos :: [Int] -> [Int] -> Int

nOcurrenciasArbolSubconjuntos xs ys =

nOcurrencias xs (arbolSubconjuntos ys)

-- (nOcurrencias x a) es el número de veces que aparece x en el árbol

-- a. Por ejemplo,

-- nOcurrencias 3 (arbolSubconjuntos 30) == 2

nOcurrencias :: [Int] -> Arbol -> Int

nOcurrencias xs (N ys [])

| conjunto xs == conjunto ys = 1

| otherwise = 0

nOcurrencias xs (N ys zs)

| conjunto xs == conjunto ys = 1 + sum [nOcurrencias xs z | z <- zs]

| otherwise = sum [nOcurrencias xs z | z <- zs]

-- (conjunto xs) es el conjunto ordenado correspondiente a xs. Por

-- ejemplo,

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

conjunto :: [Int] -> [Int]

conjunto = nub . sort

-- La propiedad es

prop_nOcurrencias :: (Positive Int) -> [Int] -> Bool

prop_nOcurrencias (Positive n) xs =

nOcurrenciasArbolSubconjuntos ys [1..n] == factorial (n-k)

where ys = nub [1 + x `mod` n | x <- xs]

k = length ys

factorial m = product [1..m]

-- La comprobación es

-- λ> quickCheckWith (stdArgs {maxSize=9}) prop_nOcurrencias

-- +++ OK, passed 100 tests.

Pensamiento

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

Antonio Machado

Problema del dominó

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

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

Definir la función

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

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

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

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

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

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

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

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

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

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

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

[]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

84480

Soluciones

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

-- 1ª solución (por búsqueda en anchura)
-- =====================================

-- Las fichas son pares de números enteros.
type Ficha  = (Int,Int)

-- Un problema está definido por la lista de fichas que hay que colocar
type Problema = [Ficha]

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

-- (inicial p) es el estado inicial del problema p.
inicial :: Problema -> Estado
inicial p = (p,[])

-- (es final e) se verifica si e es un estado final.
esFinal :: Estado -> Bool
esFinal (fs,_) = null fs 

sucesores :: Estado -> [Estado]
sucesores (fs,[]) =
  [(delete f fs, [f]) | f <- fs]
sucesores (fs,n@((x,y):qs)) =
  [(delete (u,v) fs,(u,v):n) | (u,v) <- fs, u /= v, v == x] ++
  [(delete (u,v) fs,(v,u):n) | (u,v) <- fs, u /= v, u == x] ++
  [(delete (u,v) fs,(u,v):n) | (u,v) <- fs, u == v, u == x] 

soluciones :: Problema -> [Estado]
soluciones p = busca [(inicial p)]
  where
    busca []        = []
    busca (e:es)  
      | esFinal e = e : busca es
      | otherwise = busca (es ++ sucesores e)

domino :: Problema -> [[Ficha]]
domino ps = map snd (soluciones ps)
      
-- 2ª solución (por búsqueda en profundidad)
-- =========================================

soluciones2 :: Problema -> [Estado]
soluciones2 p = busca [(inicial p)]
  where
    busca []        = []
    busca (e:es)  
      | esFinal e = e : busca es
      | otherwise = busca (sucesores e ++ es)

domino2 :: Problema -> [[Ficha]]
domino2 ps = map snd (soluciones2 ps)
      
-- 3ª solución (con I1M.BusquedaEnEspaciosDeEstados)
-- =================================================

domino3 :: Problema -> [[Ficha]]
domino3 ps = map snd (soluciones3 ps)

soluciones3 :: Problema -> [Estado]
soluciones3 ps = buscaEE sucesores
                         esFinal         
                         (inicial ps)

import I1M.BusquedaEnEspaciosDeEstados (buscaEE)

import Data.List (delete)

-- 1ª solución (por búsqueda en anchura)

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

-- Las fichas son pares de números enteros.

type Ficha = (Int,Int)

-- Un problema está definido por la lista de fichas que hay que colocar

type Problema = [Ficha]

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

-- colocadas.

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

-- (inicial p) es el estado inicial del problema p.

inicial :: Problema -> Estado

inicial p = (p,[])

-- (es final e) se verifica si e es un estado final.

esFinal :: Estado -> Bool

esFinal (fs,_) = null fs

sucesores :: Estado -> [Estado]

sucesores (fs,[]) =

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

sucesores (fs,n@((x,y):qs)) =

[(delete (u,v) fs,(u,v):n) | (u,v) <- fs, u /= v, v == x] ++

[(delete (u,v) fs,(v,u):n) | (u,v) <- fs, u /= v, u == x] ++

[(delete (u,v) fs,(u,v):n) | (u,v) <- fs, u == v, u == x]

soluciones :: Problema -> [Estado]

soluciones p = busca [(inicial p)]

where

busca [] = []

busca (e:es)

| esFinal e = e : busca es

| otherwise = busca (es ++ sucesores e)

domino :: Problema -> [[Ficha]]

domino ps = map snd (soluciones ps)

-- 2ª solución (por búsqueda en profundidad)

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

soluciones2 :: Problema -> [Estado]

soluciones2 p = busca [(inicial p)]

where

busca [] = []

busca (e:es)

| esFinal e = e : busca es

| otherwise = busca (sucesores e ++ es)

domino2 :: Problema -> [[Ficha]]

domino2 ps = map snd (soluciones2 ps)

-- 3ª solución (con I1M.BusquedaEnEspaciosDeEstados)

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

domino3 :: Problema -> [[Ficha]]

domino3 ps = map snd (soluciones3 ps)

soluciones3 :: Problema -> [Estado]

soluciones3 ps = buscaEE sucesores

esFinal

(inicial ps)

El problema de las celebridades

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

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

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

Definir la función

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

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

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

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

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

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

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

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

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

Soluciones

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

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

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

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

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

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

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

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

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

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

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

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

import Data.List (delete, nub)

import Data.Maybe (listToMaybe)

import qualified Data.Set as S

-- 1ª solución

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

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

celebridad1 r =

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

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

personas r =

nub (map fst r ++ map snd r)

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

esCelebridad r x =

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

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

where ys = delete x (personas r)

-- 2ª solución

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

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

celebridad2 r =

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

where c = S.fromList r

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

-- [1,2,3]

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

personas2 c =

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

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

esCelebridad2 c x =

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

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

where ys = delete x (personas2 c)

-- 3ª definición

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

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

celebridad3 r

| S.null candidatos = Nothing

| esCelebridad = Just candidato

| otherwise = Nothing

where

conjunto = S.fromList r

dominio = S.map fst conjunto

rango = S.map snd conjunto

total = dominio `S.union` rango

candidatos = rango `S.difference` dominio

candidato = S.findMin candidatos

noCandidatos = S.delete candidato total

esCelebridad =

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

-- Comparación de eficiencia

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

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

-- Just 1

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

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

-- Just 1

-- (0.01 secs, 0 bytes)

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

-- Just 1000

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

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

-- Just 1000

-- (0.02 secs, 0 bytes)

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

-- Just 1000000

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

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

-- Just 1

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

Cruce de listas

PorJosé A. Alonso 5-marzo-201812-marzo-2018

Definir la función

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

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

tal que (cruce xs ys) es la lista de las listas obtenidas uniendo las listas de xs sin un elemento con las de ys sin un elemento. Por ejemplo,

   ghci> cruce [1,5,3] [2,4]
   [[5,3,4],[5,3,2],[1,3,4],[1,3,2],[1,5,4],[1,5,2]]
   ghci> cruce [1,5,3] [2,4,6]
   [[5,3,4,6],[5,3,2,6],[5,3,2,4],[1,3,4,6],[1,3,2,6],
    [1,3,2,4],[1,5,4,6],[1,5,2,6],[1,5,2,4]]

ghci> cruce [1,5,3] [2,4]

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

ghci> cruce [1,5,3] [2,4,6]

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

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

Comprobar con QuickCheck que el número de elementos de (cruce xs ys) es el producto de los números de elementos de xs y de ys.

Soluciones

import Data.List (delete)
import Test.QuickCheck

cruce :: Eq a => [a] -> [a] -> [[a]]
cruce xs ys = [(delete x xs) ++ (delete y ys) | x <- xs, y <- ys]

-- La propiedad es
prop_cruce :: Eq a => [a] -> [a] -> Bool
prop_cruce xs ys =
  length (cruce xs ys) == length xs * length ys

-- La comprobación es
--    ghci> quickCheck prop_cruce
--    +++ OK, passed 100 tests.

import Data.List (delete)

import Test.QuickCheck

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

cruce xs ys = [(delete x xs) ++ (delete y ys) | x <- xs, y <- ys]

-- La propiedad es

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

prop_cruce xs ys =

length (cruce xs ys) == length xs * length ys

-- La comprobación es

-- ghci> quickCheck prop_cruce

-- +++ OK, passed 100 tests.

El problema 3SUM

PorJosé A. Alonso 2-enero-201819-febrero-2018

El problem 3SUM consiste en dado una lista xs, decidir si xs posee tres elementos cuya suma sea cero. Por ejemplo, en [7,5,-9,5,2] se pueden elegir los elementos 7, -9 y 2 que suman 0.

Definir las funciones

   sols3Sum :: [Int] -> [[Int]]
   pb3Sum :: [Int] -> Bool

1 2	sols3Sum :: [Int] -> [[Int]] pb3Sum :: [Int] -> Bool

tales que
+ (sols3Sum xs) son las listas de tres elementos de xs cuya suma sea cero. Por ejemplo,

      sols3Sum [8,10,-10,-7,2,-3]   ==  [[-10,2,8],[-7,-3,10]]
      sols3Sum [-2..3]              ==  [[-2,-1,3],[-2,0,2],[-1,0,1]]
      sols3Sum [1,-2]               ==  []
      sols3Sum [-2,1]               ==  []
      sols3Sum [1,-2,1]             ==  [[-2,1,1]]
      length (sols3Sum [-100..100]) ==  5000

sols3Sum [8,10,-10,-7,2,-3] == [[-10,2,8],[-7,-3,10]]

sols3Sum [-2..3] == [[-2,-1,3],[-2,0,2],[-1,0,1]]

sols3Sum [1,-2] == []

sols3Sum [-2,1] == []

sols3Sum [1,-2,1] == [[-2,1,1]]

length (sols3Sum [-100..100]) == 5000

(pb3Sum xs) se verifica si xs posee tres elementos cuya suma sea cero. Por ejemplo,

     pb3Sum [8,10,-10,-7,2,-3]  ==  True
     pb3Sum [1,-2]              ==  False
     pb3Sum [-2,1]              ==  False
     pb3Sum [1,-2,1]            ==  True
     pb3Sum [1..400]            ==  False

pb3Sum [8,10,-10,-7,2,-3] == True

pb3Sum [1,-2] == False

pb3Sum [-2,1] == False

pb3Sum [1,-2,1] == True

pb3Sum [1..400] == False

Soluciones

import Data.List

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

sols3Sum1 :: [Int] -> [[Int]]
sols3Sum1 = normaliza . sols3Sum1Aux 

sols3Sum1Aux :: [Int] -> [[Int]]
sols3Sum1Aux xs =
  [ys | ys <- subsequences xs
      , length ys == 3
      , sum ys == 0]

normaliza :: [[Int]] -> [[Int]]
normaliza = sort . nub . map sort

pb3Sum1 :: [Int] -> Bool
pb3Sum1 = not . null . sols3Sum1Aux


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

sols3Sum2 :: [Int] -> [[Int]]
sols3Sum2 = normaliza . sols3Sum2Aux 

sols3Sum2Aux :: [Int] -> [[Int]]
sols3Sum2Aux xs =
  [[a,b,c] | (a:bs) <- tails xs
           , (b:cs) <- tails bs
           , c <- cs
           , a + b + c == 0]
  
pb3Sum2 :: [Int] -> Bool
pb3Sum2 = not . null . sols3Sum2Aux

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

sols3Sum3 :: [Int] -> [[Int]]
sols3Sum3 = normaliza . sols3Sum3Aux 

sols3Sum3Aux :: [Int] -> [[Int]]
sols3Sum3Aux xs =
  [[a,b,-a-b] | (a:bs) <- tails xs
              , b <- bs
              , (-a-b) `elem` (delete a (delete b xs))]

pb3Sum3 :: [Int] -> Bool
pb3Sum3 = not . null . sols3Sum3Aux

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

--    λ> pb3Suma [1..23]
--    False
--    (2.61 secs, 1,812,734,176 bytes)
--    λ> pb3Sumb [1..23]
--    False
--    (0.01 secs, 554,496 bytes)
--    λ> pb3Sumc [1..23]
--    False
--    (0.01 secs, 584,344 bytes)
--    λ> pb3Suma ([1..23] ++ [-3]) 
--    True
--    (2.54 secs, 1,812,735,784 bytes)
--    λ> pb3Sumb ([1..23] ++ [-3]) 
--    True
--    (0.01 secs, 148,904 bytes)
--    λ> pb3Sumc ([1..23] ++ [-3]) 
--    True
--    (0.00 secs, 145,320 bytes)
--
--    λ> pb3Sumb [1..300]
--    False
--    (1.66 secs, 933,699,824 bytes)
--    λ> pb3Sumc [1..300]
--    False
--    (0.41 secs, 873,168,120 bytes)

import Data.List

-- 1ª solución

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

sols3Sum1 :: [Int] -> [[Int]]

sols3Sum1 = normaliza . sols3Sum1Aux

sols3Sum1Aux :: [Int] -> [[Int]]

sols3Sum1Aux xs =

[ys | ys <- subsequences xs

, length ys == 3

, sum ys == 0]

normaliza :: [[Int]] -> [[Int]]

normaliza = sort . nub . map sort

pb3Sum1 :: [Int] -> Bool

pb3Sum1 = not . null . sols3Sum1Aux

-- 2ª solución

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

sols3Sum2 :: [Int] -> [[Int]]

sols3Sum2 = normaliza . sols3Sum2Aux

sols3Sum2Aux :: [Int] -> [[Int]]

sols3Sum2Aux xs =

[[a,b,c] | (a:bs) <- tails xs

, (b:cs) <- tails bs

, c <- cs

, a + b + c == 0]

pb3Sum2 :: [Int] -> Bool

pb3Sum2 = not . null . sols3Sum2Aux

-- 3ª solución

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

sols3Sum3 :: [Int] -> [[Int]]

sols3Sum3 = normaliza . sols3Sum3Aux

sols3Sum3Aux :: [Int] -> [[Int]]

sols3Sum3Aux xs =

[[a,b,-a-b] | (a:bs) <- tails xs

, b <- bs

, (-a-b) `elem` (delete a (delete b xs))]

pb3Sum3 :: [Int] -> Bool

pb3Sum3 = not . null . sols3Sum3Aux

-- Comparación de eficiencia

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

-- λ> pb3Suma [1..23]

-- False

-- (2.61 secs, 1,812,734,176 bytes)

-- λ> pb3Sumb [1..23]

-- False

-- (0.01 secs, 554,496 bytes)

-- λ> pb3Sumc [1..23]

-- False

-- (0.01 secs, 584,344 bytes)

-- λ> pb3Suma ([1..23] ++ [-3])

-- True

-- (2.54 secs, 1,812,735,784 bytes)

-- λ> pb3Sumb ([1..23] ++ [-3])

-- True

-- (0.01 secs, 148,904 bytes)

-- λ> pb3Sumc ([1..23] ++ [-3])

-- True

-- (0.00 secs, 145,320 bytes)

-- λ> pb3Sumb [1..300]

-- False

-- (1.66 secs, 933,699,824 bytes)

-- λ> pb3Sumc [1..300]

-- False

-- (0.41 secs, 873,168,120 bytes)

El problema de las celebridades

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

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

Definir la función

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

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

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

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

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

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

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

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

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

Soluciones

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

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

[/schedule]

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

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

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

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

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

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

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

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

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

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

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

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

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

import Data.List (delete, nub)

import Data.Maybe (listToMaybe)

import qualified Data.Set as S

-- 1ª solución

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

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

celebridad1 r =

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

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

personas r =

nub (map fst r ++ map snd r)

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

esCelebridad r x =

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

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

where ys = delete x (personas r)

-- 2ª solución

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

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

celebridad2 r =

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

where c = S.fromList r

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

-- [1,2,3]

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

personas2 c =

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

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

esCelebridad2 c x =

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

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

where ys = delete x (personas2 c)

-- 3ª definición

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

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

celebridad3 r

| S.null candidatos = Nothing

| esCelebridad = Just candidato

| otherwise = Nothing

where

conjunto = S.fromList r

dominio = S.map fst conjunto

rango = S.map snd conjunto

total = dominio `S.union` rango

candidatos = rango `S.difference` dominio

candidato = S.findMin candidatos

noCandidatos = S.delete candidato total

esCelebridad =

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

-- Comparación de eficiencia

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

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

-- Just 1

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

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

-- Just 1

-- (0.01 secs, 0 bytes)

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

-- Just 1000

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

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

-- Just 1000

-- (0.02 secs, 0 bytes)

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

-- Just 1000000

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

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

-- Just 1

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

[/schedule]

Eliminación de triplicados

PorJosé A. Alonso 31-enero-20178-febrero-2017

Definir la función

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

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

tal que (sinTriplicados xs) es la lista obtenida dejando en xs sólo las dos primeras ocurrencias de cada uno de sus elementos. Por ejemplo,

   sinTriplicados "aaabcbccdbabdcd"  ==  "aabcbcdd"
   sinTriplicados "xxxxx"            ==  "xx"
   sinTriplicados "abcabc"           ==  "abcabc"
   sinTriplicados "abcdabcaba"       ==  "abcdabc"
   sinTriplicados "abacbadcba"       ==  "abacbdc"
   sinTriplicados "aaabcbccdbabdcd"  ==  "aabcbcdd"
   sinTriplicados (show (5^4^3))     ==  "54210108624757363989"
   sinTriplicados (show (8^8^8))     ==  "60145207536139279488"

sinTriplicados "aaabcbccdbabdcd" == "aabcbcdd"

sinTriplicados "xxxxx" == "xx"

sinTriplicados "abcabc" == "abcabc"

sinTriplicados "abcdabcaba" == "abcdabc"

sinTriplicados "abacbadcba" == "abacbdc"

sinTriplicados "aaabcbccdbabdcd" == "aabcbcdd"

sinTriplicados (show (5^4^3)) == "54210108624757363989"

sinTriplicados (show (8^8^8)) == "60145207536139279488"

Soluciones

import Data.List (delete)

sinTriplicados :: Eq a => [a] -> [a]
sinTriplicados xs = aux xs [] []
  where aux [] _ _ = []
        aux (x:xs) ys zs
          | x `elem` zs = aux xs ys zs
          | x `elem` ys = x : aux xs (delete x ys) (x:zs)
          | otherwise   = x : aux xs (x:ys) zs

import Data.List (delete)

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

sinTriplicados xs = aux xs [] []

where aux [] _ _ = []

aux (x:xs) ys zs

| x `elem` zs = aux xs ys zs

| x `elem` ys = x : aux xs (delete x ys) (x:zs)

| otherwise = x : aux xs (x:ys) zs

Máximo producto de pares en la lista

PorJosé A. Alonso 30-enero-201726-marzo-2022

Definir la función

  maximoProducto :: [Int] -> Maybe Int

1	maximoProducto :: [Int] -> Maybe Int

tal que (maximoProducto xs) es el mayor elemento de xs que se puede escribir
como producto de dos elementos distintos de xs o Nothing, en el caso de que
ningún elemento de xs se pueda escribir como producto de dos elementos
distintos de xs, donde xs es una lista de números mayores que 0. Por ejemplo,

   maximoProducto [10, 3, 5, 30, 35]       ==  Just 30
   maximoProducto [10, 2, 2, 4, 30, 35]    ==  Just 4
   maximoProducto [17, 2, 1, 35, 30]       ==  Just 35
   maximoProducto [2,4]                    ==  Nothing
   maximoProducto [2, 5, 7, 8]             ==  Nothing
   maximoProducto [10, 2, 4, 30, 35]       ==  Nothing
   maximoProducto [1+2^n | n <- [1..10^6]] ==  Just 4611686018427387905

maximoProducto [10, 3, 5, 30, 35] == Just 30

maximoProducto [10, 2, 2, 4, 30, 35] == Just 4

maximoProducto [17, 2, 1, 35, 30] == Just 35

maximoProducto [2,4] == Nothing

maximoProducto [2, 5, 7, 8] == Nothing

maximoProducto [10, 2, 4, 30, 35] == Nothing

maximoProducto [1+2^n | n <- [1..10^6]] == Just 4611686018427387905

En el primer ejemplo, 30 es el producto de 10 y 3; en el segundo, 4 es el producto de 2 y 2 y en el tercero, 35 es el producto de 1 y 35.

Soluciones

import Data.List (delete, nub, sort)

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

maximoProducto1 :: [Int] -> Maybe Int
maximoProducto1 xs
  | null zs   = Nothing
  | otherwise = Just (head zs)
  where
    ys = reverse (sort xs)
    zs = [y | y <- ys, y `elem` productos xs]

-- (productos xs) es la lista de los números que son productos de dos
-- elementos de xs. Por ejemplo, 
--   productos [4,3,5,2]  ==  [12,20,8,15,6,10]
productos :: [Int] -> [Int]
productos xs =
  nub [y * z | y <- xs, z <- delete y xs]

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

maximoProducto2 :: [Int] -> Maybe Int
maximoProducto2 xs = aux (reverse (sort xs))
  where aux []     = Nothing
        aux (y:ys) | esProducto y xs = Just y
                   | otherwise       = aux ys

esProducto :: Int -> [Int] -> Bool
esProducto y []     = False
esProducto y (x:xs) = 
  (m == 0 && d `elem` xs) || esProducto y xs
  where (d,m) = divMod y x  

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

--    λ> maximoProducto1 [1..10^4]
--    Just 10000
--    (2.60 secs, 0 bytes)
--    λ> maximoProducto2 [1..10^4]
--    Just 10000
--    (0.01 secs, 0 bytes)

import Data.List (delete, nub, sort)

-- 1ª solución

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

maximoProducto1 :: [Int] -> Maybe Int

maximoProducto1 xs

| null zs = Nothing

| otherwise = Just (head zs)

where

ys = reverse (sort xs)

zs = [y | y <- ys, y `elem` productos xs]

-- (productos xs) es la lista de los números que son productos de dos

-- elementos de xs. Por ejemplo,

-- productos [4,3,5,2] == [12,20,8,15,6,10]

productos :: [Int] -> [Int]

productos xs =

nub [y * z | y <- xs, z <- delete y xs]

-- 2ª solución

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

maximoProducto2 :: [Int] -> Maybe Int

maximoProducto2 xs = aux (reverse (sort xs))

where aux [] = Nothing

aux (y:ys) | esProducto y xs = Just y

| otherwise = aux ys

esProducto :: Int -> [Int] -> Bool

esProducto y [] = False

esProducto y (x:xs) =

(m == 0 && d `elem` xs) || esProducto y xs

where (d,m) = divMod y x

-- Comparación de eficiencia

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

-- λ> maximoProducto1 [1..10^4]

-- Just 10000

-- (2.60 secs, 0 bytes)

-- λ> maximoProducto2 [1..10^4]

-- Just 10000

-- (0.01 secs, 0 bytes)

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)

Juego de bloques con letras

PorJosé A. Alonso 12-mayo-201619-mayo-2016

Para el juego de los bloques se dispone de un conjunto de bloques con una letra en cada una de sus dos caras. El objetivo del juego consiste en formar palabras sin que se pueda usar un bloque más de una vez y sin diferenciar mayúsculas de minúsculas. Por ejemplo, si se tiene tres bloques de forma que el 1º tiene las letras A y B, el 2ª la N y la O y el 3º la O y la A entonces se puede obtener la palabra ANA de dos formas: una con los bloques 1, 2 y 3 y otra con los 3, 2 y 1.

Definir la función

   soluciones :: [String] -> String -> [[String]]

1	soluciones :: [String] -> String -> [[String]]

tal que (soluciones bs cs) es la lista de las soluciones del juego de los bloque usando los bloques bs (cada bloque es una cadena de dos letras mayúsculas) para formar la palabra cs. Por ejemplo,

   ghci> soluciones ["AB","NO","OA"] "ANA"
   [["AB","NO","OA"],["OA","NO","AB"]]
   ghci> soluciones ["AB","NE","OA"] "Bea"
   [["AB","NE","OA"]]
   ghci> soluciones ["AB","NE","OA"] "EvA"
   []
   ghci> soluciones ["AB","NO","OA","NC"] "ANA"
   [["AB","NO","OA"],["AB","NC","OA"],["OA","NO","AB"],["OA","NC","AB"]]
   ghci> soluciones ["AB","NO","OA","NC"] "Anca"
   [["AB","NO","NC","OA"],["OA","NO","NC","AB"]]
   ghci> soluciones (["AB","NO","OA"] ++ replicate (10^6) "PQ") "ANA"
   [["AB","NO","OA"],["OA","NO","AB"]]

ghci> soluciones ["AB","NO","OA"] "ANA"

[["AB","NO","OA"],["OA","NO","AB"]]

ghci> soluciones ["AB","NE","OA"] "Bea"

[["AB","NE","OA"]]

ghci> soluciones ["AB","NE","OA"] "EvA"

[]

ghci> soluciones ["AB","NO","OA","NC"] "ANA"

[["AB","NO","OA"],["AB","NC","OA"],["OA","NO","AB"],["OA","NC","AB"]]

ghci> soluciones ["AB","NO","OA","NC"] "Anca"

[["AB","NO","NC","OA"],["OA","NO","NC","AB"]]

ghci> soluciones (["AB","NO","OA"] ++ replicate (10^6) "PQ") "ANA"

[["AB","NO","OA"],["OA","NO","AB"]]

Soluciones

import Data.List (delete)
import Data.Char (toUpper)

soluciones :: [String] -> String -> [[String]]
soluciones _ []      = [[]]
soluciones bs (c:cs) = [b:rs | b <- bs, 
                               toUpper c `elem` b,
                               rs <- soluciones (delete b bs) cs]

import Data.List (delete)

import Data.Char (toUpper)

soluciones :: [String] -> String -> [[String]]

soluciones _ [] = [[]]

soluciones bs (c:cs) = [b:rs | b <- bs,

toUpper c `elem` b,

rs <- soluciones (delete b bs) cs]

Mínima diferencia entre elementos de una lista

PorJosé A. Alonso 18-abril-201625-abril-2016

Definir la función

   minimaDiferencia :: (Num a, Ord a) => [a] -> a

1	minimaDiferencia :: (Num a, Ord a) => [a] -> a

tal que (minimaDiferencia xs) es el menor valor absoluto de las diferencias entre todos los pares de elementos de xs (que se supone que tiene al menos 2 elementos). Por ejemplo,

   minimaDiferencia [1,5,3,19,18,25]  ==  1
   minimaDiferencia [30,5,20,9]       ==  4
   minimaDiferencia [30,5,20,9,5]     ==  0
   minimaDiferencia [1..10^6]         ==  1

minimaDiferencia [1,5,3,19,18,25] == 1

minimaDiferencia [30,5,20,9] == 4

minimaDiferencia [30,5,20,9,5] == 0

minimaDiferencia [1..10^6] == 1

En el primer ejemplo la menor diferencia es 1 y se da entre los elementos 19 y 18; en el 2ª es 4 entre los elementos 5 y 9 y en la 3ª es 0 porque el elemento 5 está repetido.

Soluciones

import Data.List (delete, sort)

-- 1ª definición    
minimaDiferencia1 :: (Num a, Ord a) => [a] -> a
minimaDiferencia1 xs =
    minimum [abs (x - y) | x <- xs, y <- delete x xs]

-- 2ª definición    
minimaDiferencia2 :: (Num a, Ord a) => [a] -> a
minimaDiferencia2 [x,y]  = abs (x - y)
minimaDiferencia2 (x:xs) = min (minimum [abs (x - y) | y <- xs])
                               (minimaDiferencia2 xs)      

-- 3ª definición    
minimaDiferencia3 :: (Num a, Ord a) => [a] -> a
minimaDiferencia3 xs =
    minimum [y - x | (x,y) <- zip ys (tail ys)]
    where ys = sort xs

-- Comparación de eficiencia
--    λ> minimaDiferencia1 [1..2*10^3]
--    1
--    (3.47 secs, 1,419,790,688 bytes)
--    λ> minimaDiferencia2 [1..2*10^3]
--    1
--    (0.78 secs, 684,030,712 bytes)
--    λ> minimaDiferencia3 [1..2*10^3]
--    1
--    (0.02 secs, 0 bytes)
--    
--    λ> minimaDiferencia2 [1..5*10^3]
--    1
--    (5.14 secs, 4,233,952,776 bytes)
--    λ> minimaDiferencia3 [1..5*10^3]
--    1
--    (0.02 secs, 0 bytes)

import Data.List (delete, sort)

-- 1ª definición

minimaDiferencia1 :: (Num a, Ord a) => [a] -> a

minimaDiferencia1 xs =

minimum [abs (x - y) | x <- xs, y <- delete x xs]

-- 2ª definición

minimaDiferencia2 :: (Num a, Ord a) => [a] -> a

minimaDiferencia2 [x,y] = abs (x - y)

minimaDiferencia2 (x:xs) = min (minimum [abs (x - y) | y <- xs])

(minimaDiferencia2 xs)

-- 3ª definición

minimaDiferencia3 :: (Num a, Ord a) => [a] -> a

minimaDiferencia3 xs =

minimum [y - x | (x,y) <- zip ys (tail ys)]

where ys = sort xs

-- Comparación de eficiencia

-- λ> minimaDiferencia1 [1..2*10^3]

-- 1

-- (3.47 secs, 1,419,790,688 bytes)

-- λ> minimaDiferencia2 [1..2*10^3]

-- 1

-- (0.78 secs, 684,030,712 bytes)

-- λ> minimaDiferencia3 [1..2*10^3]

-- 1

-- (0.02 secs, 0 bytes)

-- λ> minimaDiferencia2 [1..5*10^3]

-- 1

-- (5.14 secs, 4,233,952,776 bytes)

-- λ> minimaDiferencia3 [1..5*10^3]

-- 1

-- (0.02 secs, 0 bytes)

Juego de bloques con letras

PorJosé A. Alonso 12-diciembre-201425-abril-2021

Introducción

Enunciado

-- Definir la función 
--    soluciones :: [String] -> String -> [[String]]
-- tal que (soluciones bs cs) es la lista de las soluciones del juego de
-- los bloque usando los bloques bs (cada bloque es una cadena de dos
-- letras mayúsculas) para formar la palabra cs. Por ejemplo,
--    ghci> soluciones ["AB","NO","OA"] "ANA"
--    [["AB","NO","OA"],["OA","NO","AB"]]
--    ghci> soluciones ["AB","NE","OA"] "Bea"
--    [["AB","NE","OA"]]
--    ghci> soluciones ["AB","NE","OA"] "EvA"
--    []
--    ghci> soluciones ["AB","NO","OA","NC"] "ANA"
--    [["AB","NO","OA"],["AB","NC","OA"],["OA","NO","AB"],["OA","NC","AB"]]
--    ghci> soluciones ["AB","NO","OA","NC"] "Anca"
--    [["AB","NO","NC","OA"],["OA","NO","NC","AB"]]

-- Definir la función

-- soluciones :: [String] -> String -> [[String]]

-- tal que (soluciones bs cs) es la lista de las soluciones del juego de

-- los bloque usando los bloques bs (cada bloque es una cadena de dos

-- letras mayúsculas) para formar la palabra cs. Por ejemplo,

-- ghci> soluciones ["AB","NO","OA"] "ANA"

-- [["AB","NO","OA"],["OA","NO","AB"]]

-- ghci> soluciones ["AB","NE","OA"] "Bea"

-- [["AB","NE","OA"]]

-- ghci> soluciones ["AB","NE","OA"] "EvA"

-- []

-- ghci> soluciones ["AB","NO","OA","NC"] "ANA"

-- [["AB","NO","OA"],["AB","NC","OA"],["OA","NO","AB"],["OA","NC","AB"]]

-- ghci> soluciones ["AB","NO","OA","NC"] "Anca"

-- [["AB","NO","NC","OA"],["OA","NO","NC","AB"]]

Soluciones

import Data.List (delete)
import Data.Char (toUpper)

soluciones :: [String] -> String -> [[String]]
soluciones _ []      = [[]]
soluciones bs (c:cs) = [b:rs | b <- bs, 
                               toUpper c `elem` b,
                               rs <- soluciones (delete b bs) cs]

import Data.List (delete)

import Data.Char (toUpper)

soluciones :: [String] -> String -> [[String]]

soluciones _ [] = [[]]

soluciones bs (c:cs) = [b:rs | b <- bs,

toUpper c `elem` b,

rs <- soluciones (delete b bs) cs]

Soluciones

Nuevas soluciones

Soluciones

Soluciones

Otras soluciones

Soluciones

Referencia

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Pensamiento

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Introducción

Enunciado

Soluciones

Entradas recientes

Buscar

Correo electrónico