Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- import Data.Maybe (fromJust, catMaybes)
- import Data.List (subsequences, findIndex, findIndices)
- import Data.Word(Word8)
- import qualified Data.ByteString.Lazy as BL
- import Data.Binary.Put
- data Op = UP | DN deriving (Show, Eq)
- -- Generalizaciones (limpiar; mala estructura, usar folds)
- paso :: (Integral a) => (a -> a) -> a -> a
- paso hazpar x = if odd x then div (hazpar x) 2 else div x 2
- serie_infinita :: (Integral a) => (a -> a) -> a -> [Op]
- serie_infinita f x = (if odd x then UP else DN) : (serie_infinita f siguiente) where
- siguiente = paso f x
- -- Al no conocer f, no se sabe cual (si existe) es el ciclo límite.
- -- Hay que dar como propuesta un elemento del ciclo esperado.
- serie :: (Integral a) => (a -> a) -> a -> a -> [Op]
- serie f final x
- | x == final = []
- | otherwise = (if odd x then UP else DN) : (serie f final siguiente) where
- siguiente = paso f x
- -- Funciones de hacer par
- -- no se puede usar (-1) porque es número negativo, no función
- binarios :: (Integral a) => a -> a
- binarios = (\ k -> k - 1)
- collatz :: (Integral a) => a -> a
- collatz = (+1).(*3)
- --collatz x = (3*x)+1
- -- Construir el árbol de congruencias
- -- [3, 5, 4, 1, 0, 2] --> [4, 3, 5, 0, 2, 1]
- reordena :: (Integral a) => [a] -> [Int]
- reordena xs = map (\k -> fromJust $ findIndex (==k) xs) [0..(fromIntegral $ length xs - 1)]
- nivel :: (Integral a) => (a -> a) -> a -> [Int]
- nivel f n = reordena xs where
- xs = 0 : map (serie_a_entero.reverse.(take $ fromIntegral n).(serie_infinita f)) [1..((2^n)-1)]
- torsiones :: (Integral a) => [a] -> [Int]
- torsiones xs = findIndices id $ alternosCon (>) xs
- --comp_torsiones xs = findIndices id $ alternosCon (<) xs
- -- Igualdades
- -- dos listas son iguales hasta donde están definidas;
- -- e.g. [1..10] ==: [1..20] --> True
- (==:) :: (Eq a) => [a] -> [a] -> Bool
- (==:) x y = all id $ zipWith (==) x y
- infix 4 ==:
- -- Igualdad izquierda: nivel y nivel siguiente
- igualdad1 :: (Integral a) => (a -> a) -> a -> Bool
- igualdad1 f n = nivel f (n+1) ==: map (2*) (nivel f n)
- -- Igualdad central: el segundo cuarto del lado izquierdo y
- -- el primer cuarto del lado derecho
- igualdad2 :: (Integral a) => (a -> a) -> a -> Bool
- igualdad2 f n = (map (+1) izq) == der where
- t = nivel f n
- izq = take k $ drop k t
- der = take k $ drop j t
- k = 2^(n-3)
- j = 2^(n-1)
- -- Igualdad derecha: el número de entradas iguales depende de
- -- cuantos niveles de separación hay
- igualdad3 :: (Integral a) => (a -> a) -> a -> a -> Bool
- igualdad3 f n offpow = (conjuga base) == desplazado where
- t = nivel f n
- offset = 2^offpow
- longitud = min (if offset > 1 then 4*offset else 2) (2^(n-offset))
- base = idrop (2^(n-offset) - longitud) $ itake (2^(n-offset)) t
- desplazado = idrop (2^n - longitud) t
- conjuga xs = map (\k -> k + 2^offset - 1) xs
- -- con 'offset' niveles de separación
- -- 'offset' aparentemente debe ser potencia de 2
- igualdad3b :: (Integral a) => (a -> a) -> a -> a -> Bool
- igualdad3b f n offpow = (conjuga base) ==: desplazado where
- offset = 2^offpow
- longitud = if offset > 1 then 4*offset else 2
- base = take (fromIntegral longitud) $ reverse $ nivel f n
- desplazado = take (fromIntegral longitud) $ reverse $ nivel f (n+offset)
- conjuga xs = map (\k -> ((k+1)*(2^offset))-1) xs
- igualdad3c :: (Integral a) => (a -> a) -> a -> a -> Bool
- igualdad3c f n offpow = (conjuga base) == desplazado where
- offset = 2^offpow
- -- min: si el nivel base no alcanza a cubrir
- longitud = min (if offset > 1 then 4*offset else 2) (2^n)
- base = idrop (2^n - longitud) $ nivel f n
- desplazado = idrop (2^(n+offset) - longitud) $ nivel f (n+offset)
- conjuga xs = map (\k -> ((k+1)*(2^offset))-1) xs
- -- Auxiliares
- -- como binarios, UP es 1, DN es 0, la potencia mínima está a la izquierda (usar reverse si
- -- es necesario)
- serie_a_entero :: [Op] -> Integer
- serie_a_entero xs = sum $ zipWith (\ j k -> if j == UP then k else 0) xs (map (2^) [0..])
- -- requiere entrada de longitud par y no nula (no verificado)
- alternos :: [a] -> ([a],[a])
- alternos (x:y:xs) = if null xs then ([x],[y]) else (x:m, y:n) where (m, n) = alternos xs
- --alternos [x] = ([x],[])
- --alternos [] = ([],[])
- alternosCon :: (a->a->b) -> [a] -> [b]
- alternosCon f xs = zipWith f x y where
- (x, y) = alternos xs
- dropOdd = alternosCon const
- dropEven = (alternosCon const).tail
- separa n xs = a : (if null b then [] else separa n b) where (a,b) = splitAt n xs
- itake :: (Integral a) => a -> [b] -> [b]
- itake n xs = take (fromIntegral n) xs
- idrop :: (Integral a) => a -> [b] -> [b]
- idrop n xs = drop (fromIntegral n) xs
- -- Escribir a archivo
- -- el [Bool] debe tener longitud 8 (no verificado)
- a_entero :: [Bool] -> Word8
- a_entero xs = sum $ zipWith (\j k -> if k then j else 0) (map (2^) [7,6..0]) xs
- salida :: Put
- salida = mapM_ putWord8 $ map a_entero $ separa 8 $ alternosCon (>) $ nivel collatz 16
- {-
- main :: IO ()
- main = BL.putStr $ runPut salida
- -}
Add Comment
Please, Sign In to add comment