Collatz.hs

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