Ver el código de «Examen 16/02/21»

<source lang='haskell'>

-- ==================================================================
-- Informática (1º del Grado en Matemáticas), Grupo 2
-- 2º examen de evaluación continua (16 de febrero de 2021)
-- ------------------------------------------------------------------
-- Nombre: 
--
-- Apellidos: 
-- 
-- Usuario Virtual de la Universidad(UVUS):
-- ==================================================================

-- Nota 1: Es necesario que se pueda cargar el fichero. Es decir, que
-- no contenga errores sintácticos. Para ello, si alguna función no 
-- está terminada de programar o bien tiene algún error sintáctico,
-- debe estar comentada.

-- Nota 2: Hay que documentar las funciones auxilares, es decir:
--   1. Elegir un nombre para sugerir lo que hace
--   2. Escribir, en lenguaje natural, qué hace la función y no cómo lo
--      hace.
--
-- Nota 3: En cada ejercicio se valorará la corrección, claridad y 
-- eficiencia de la solución propuesta. Todos los ejercicios valen igual.

import Data.List
import Data.Char

-- ----------------------------------------------------------------------
-- Ejercicio 1
-- ----------------------------------------------------------------------
-- Un árbol de Huffman tiene la siguiente forma: los nodos no contienen
-- valores y las hojas almacenan caracteres. Para cada nodo, la rama 
-- izquierda tiene asociado el 0, y la rama derecha el 1. Además, para 
-- todo nodo, el subárbol izquierdo es siempre una hoja. Por ejemplo,
--       o
--      / \  
--   0 /   \ 1
--    /     \
--   A       o
--          / \
--       0 /   \ 1
--        /     \
--       R       o
--              / \
--           0 /   \ 1
--            /     \
--           B       K 
-- 
-- El tipo de dato que usaremos para representar un árbol de Huffman
-- es el siguiente:

data ArbolH = H Char | N (ArbolH) (ArbolH)
  deriving Show

-- Por tanto, el ejemplo anterior se representa como:
 
ahEj :: ArbolH
ahEj = N (H 'a') (N (H 'r') (N (H 'b') (H 'k')))

-- Podemos usar un árbol de Huffman para codificar en binario los 
-- caracteres que hay en él. La codificación de cada caracter es
-- simplemente el camino desde la raíz a la hoja de ese caracter.
-- Por ejemplo:
-- A    0
-- R   10
-- B  110
-- K  111
--
-- Define la función 
--      codificaHuffman :: String -> ArbolH -> [Int]
-- tal que (codificaHuffman cs a) reciba una cadena de caracteres cs, un 
-- árbol de Huffman a y devuelva una lista de enteros que represente la
-- secuencia de bits de la codificación final (0s y 1s). Para ello, hay que:
--    1. limpiar la cadena cs para que solo contenga los caracteres que 
--       existan en las hojas del árbol a, sin distinguir entre mayúsculas
--       y minúsculas
--    2. codificar cada caracter resultante de lo anterior con su codificación 
--       según el árbol.
-- 
-- Por ejemplo,
-- > codificaHuffman "ABRRKBAARAA" ahEj
-- [0,1,1,0,1,0,1,0,1,1,1,1,1,0,0,0,1,0,0,0]
-- > codificaHuffman "arbk" ahEj
-- [0,1,0,1,1,0,1,1,1]
-- > codificaHuffman "bcccc!" ahEj
-- [1,1,0]
-- > codificaHuffman "i1m" ahEj
-- []

codificaHuffman :: String -> ArbolH -> [Int]
codificaHuffman cs a = concatMap (huffaux a) cs'
    where cs' = filter (enArbol a) (map toLower cs)

huffaux :: ArbolH -> Char -> [Int]
huffaux (N (H e) a) c
  | e == c = [0]
  | otherwise = 1:huffaux a c
huffaux _ _ = []

enArbol :: ArbolH -> Char -> Bool 
enArbol (H c') c = toLower c == toLower c' 
enArbol (N a1 a2) c = enArbol a1 c || enArbol a2 c

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

-- ----------------------------------------------------------------------
-- Ejercicio 2
-- ----------------------------------------------------------------------
-- Ejercicio 2.1. Define la función
--      frecuencias :: String -> [(Char,Int)]
-- tal que (frecuencias cs) reciba una cadena de caracteres cs y devuelva
-- una lista de pares (c,f), donde c es cada caracter en cs y f es el
-- número de veces que aparece c en cs (frecuencia). La lista devuelta 
-- debe estar ordenada de mayor a menor según la frecuencia. No se deben
-- distinguir entre mayúsculas y minúsculas (es decir, 'a' y 'A' cuentan
-- igual). Por ejemplo,
-- > frecuencias "Mandalorian" 
-- [('a',3),('n',2),('r',1),('o',1),('m',1),('l',1),('i',1),('d',1)]
-- > frecuencias "aaakdkaa"
-- [('a',5),('k',2),('d',1)]
-- > frecuencias "aaaAAaaAAAAa"
-- [('a',12)]
-- NOTA: recuerda, la función sort funciona también para pares.

frecuencias :: String -> [(Char,Int)]
frecuencias cs = reverse $
                 map swap $ 
                 sort [(length (filter (==c) cs'),c)  | c <- nub cs']
  where cs' = map toLower cs 
        swap (x,y) = (y,x)

-- Ejercicio 2.2. Define la función
--    arbolHuffman :: String -> ArbolH
-- tal que (arbolHuffman cs) reciba un String y devuelva un árbol de Huffman.
-- Los caracteres se ponen en el subárbol izquierdo de cada nodo como hojas, 
-- y en orden de mayor a menor frecuencia. En concreto, el caracter con más
-- frecuencia se pone como subárbol izquierdo de la raíz, y el caracter con
-- menor frecuencia terminará en el subárbol derecho del nodo más profundo.
-- No se deben distinguir entre mayúsculas y minúsculas. Por simplicidad,
-- asume que al menos hay dos caracteres distintos.
-- > arbolHuffman "ABRRKBAARAA"
-- N (H 'a') (N (H 'r') (N (H 'b') (H 'k')))
-- >  arbolHuffman "abBcCc"
-- N (H 'c') (N (H 'b') (H 'a'))
-- >  arbolHuffman "Grogu"      
-- N (H 'g') (N (H 'u') (N (H 'r') (H 'o')))

arbolHuffman :: String -> ArbolH
arbolHuffman cs = arbHuffAux fs
  where fs = map fst $ frecuencias cs
  
arbHuffAux :: String -> ArbolH
arbHuffAux [] = error "no posible"  -- este caso se descarta por el enunciado
arbHuffAux [c1,c2] = N (H c1) (H c2)
arbHuffAux (c:cs) = N (H c) (arbHuffAux cs)

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

-- ----------------------------------------------------------------------
-- Ejercicio 3
-- ----------------------------------------------------------------------
-- La raíz cuadrada de 2 es uno de los primeros números irracionales
-- en ser descubiertos. Su valor es aproximadamente 1.4142135624.
-- En concreto, sus primeros treinta dígitos (parte entera y decimal) son:
--   1,4,1,4,2,1,3,5,6,2,3,7,3,0,9,5,0,4,8,8,0,1,6,8,8,7,2,4,2,0
-- La lista infinita de los dígitos de la raíz de dos se puede calcular
-- con un proceso que depende de tan solo dos parámetros, 'x' y 'r':
--   * Inicialmente, x=2 y r=0. 
--   * Dados x y r, se genera el dígito d, siendo d el mayor número 
--     natural de 0 a 9 tal que cumpla la condición: d(20r+d) < x
--   * Para generar el siguiene dígito, se actualizan los parámetros:
--      * x pasa a valer 100(x-d(20r+d)) 
--      * r pasa a valer (10r+d)
-- Por ejemplo,
--   * Para x=2 y r=0:
--       * d=1, ya que es el mayor natural tal que d(20*1+d) < 2
--       * El siguiente valor de x es 100(2-1(20*0+1))=100 y de r es 
--         10*0+1=1.
--   * Para x=100 y r=1:
--       * d=4, ya que 4(20*1+4) = 96 < 100
--       * El siguiente valor de x es 400 y de r es 14
--   * Para x=400 y r=14, d=1
--   * Para x=11900 y r=141, d=4
--   * Para x=60400 y r=1414, d=2
--   * ....
--
-- Ejercicio 3.1. Define la función 
--      raizDeDos :: [Int]
-- tal que devuelva la lista de dígitos de la raíz cuadrada de 2.
-- Por ejemplo,
--   >  take 31 raizDeDos       
--   [1,4,1,4,2,1,3,5,6,2,3,7,3,0,9,5,0,4,8,8,0,1,6,8,8,7,2,4,2,0,9]
-- 
-- NOTA: Cuidado, los valores de d y r pueden ser muy altos, por lo
-- que necesitarás hacer uso de Integer. Recuerda que puedes usar
-- (fromIntegral n) para traducir un Integer a un Int.

-- 1ª Solución
raizDeDos :: [Int]
raizDeDos = proceso 2 0

proceso :: Integer -> Integer -> [Int]
proceso x r = (fromIntegral dig) : proceso sigx sigr
  where dig = head (dropWhile cond [0..]) - 1
        cond d = (20 * r + d) * d < x
        sigx = 100 * (x - (20 * r + dig) * dig)
        sigr = 10 * r + dig

-- 2ª Solución
raizDeDos' :: [Int]
raizDeDos' = tail $ map fst (iterate proc (0,(2,0)))
  where proc :: (Int,(Integer,Integer)) -> (Int,(Integer,Integer))
        proc (d,(x,r)) = (fromIntegral dig,(sigx,sigr))
          where dig = last (takeWhile cond [0..])
                cond d = (20 * r + d) * d < x
                sigx = 100 * (x - (20 * r + dig) * dig)
                sigr = 10 * r + dig

-- Ejercicio 3.2. Define la función 
--     expande :: [Int] -> [Int]
-- tal que (expande xs) recibe una secuencia de enteros xs y la 
-- expande de la siguiente manera: para cada par de enteros consecutivos
-- x e y de xs, se insertan los números enteros para ir de x a y. Por
-- ejemplo, si x=1 e y=4, entonces se inserta 2,3 entre x e y. Si
-- x=8 e y=4, entonces se inserta 7,6,5. Por ejemplo,
-- > expande [1,10,1]
-- [1,2,3,4,5,6,7,8,9,10,9,8,7,6,5,4,3,2,1]
-- > take 20 $ expande raizDeDos
-- [1,2,3,4,3,2,1,2,3,4,3,2,1,2,3,4,5,6,5,4]

-- 1ª Solución
expande :: [Int] -> [Int]
expande [] = []
expande [x] = [x]
expande (x:y:xs) = genera x y ++ expande (y:xs)
 
genera :: Int -> Int -> [Int]
genera x y | x==y = [x]
           | x < y = init [x..y]
           | otherwise = init [x,x-1..y]

-- 2ª Solución
expande' :: [Int] -> [Int]
expande' xs = concat $ zipWith genera xs (tail xs)

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

-- ----------------------------------------------------------------------
-- Ejercicio 4
-- ----------------------------------------------------------------------
-- Define la función
--   digitosHasta :: Int -> Int
-- tal que (digitosHasta n) devuelva el mínimo número de dígitos de la raíz
-- cuadrada de dos necesarios para que aparezcan todos los dígitos del 0
-- al 9 al menos n veces cada uno. Por ejemplo, para que cada dígito (0 al
-- 9) aparezca al menos 2 veces se necesitan un mínimo de 31 dígitos de raíz
-- de dos. Por ejemplo,
-- > digitosHasta 1
-- 19
-- > digitosHasta 2
-- 31
-- > digitosHasta 3
-- 38
-- > digitosHasta 4
-- 47
-- > digitosHasta 100
-- 1188
-- > digitosHasta 500
-- 5328
-- NOTA: si no has definido el ejercicio 3, usa la siguiente definición y
-- prueba con hasta n = 4
--raizDeDos :: [Int]
--raizDeDos = [1,4,1,4,2,1,3,5,6,2,3,7,3,0,9,5,0,4,8,8,0,1,6,8,8,7,2,4,2,0,9,6,9,8,0,7,8,5,6,9,6,7,1,8,7,5,3,7,6,9]

-- 1ª Solución (con recursión)
digitosHasta :: Int -> Int
digitosHasta n = recorre (replicate 10 0) 0 raizDeDos
  where aumenta i xs = take i xs ++ [(xs!!i)+1] ++ drop (i+1) xs
        recorre _ _ [] = error "imposible"
        recorre ns k (x:xs)
            | all (>=n) ns = k
            | otherwise = recorre (aumenta x ns) (k+1) xs

-- 2ª Solución (con orden superior)
digitosHasta' :: Int -> Int
digitosHasta' n = (length.head) $ dropWhile p (inits raizDeDos)
  where p = not . (\xss -> length xss == 10 && all (>=n) (map length xss)) . group . sort

-- > digitosHasta 500 
-- 5328
-- (0.09 secs, 169,311,552 bytes)
-- > digitosHasta' 500
-- 5328
-- (5.22 secs, 13,704,382,352 bytes)
-- La primera solución es más eficiente en tiempo y memoria

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

</source>