0votos

Subsecuencias de Wirth en Haskell

por josejuan hace 6 años

He reducido el tiempo al 32,5% usando árboles para representar las secuencias Wirth y paralelizando los procesos (trivial en Haskell cuando son deterministas).

Encontrar todas las cadenas de N caracteres "A", "B" o "C" tales que no contengan dos subsecuencias consecutivas.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
import Data.List (isPrefixOf) 
import System.Environment (getArgs) 
import Control.Parallel 
import Control.Parallel.Strategies 
 
-- Diccionario 
abc :: String 
abc = "ABC" 
 
-- Representaré las combinaciones Wirth como un árbol n-ario 
data Tree = Node Char [Tree] deriving Show 
 
-- La menor secuencia (no vacía) Wirth 
oneTree :: [Tree] 
oneTree = map (\c -> Node c []) abc 
 
-- Toma un árbol Wirth y lo expande un nivel (es decir, dado un árbol 
-- que representa el n-wirth, genera otro como el (n+1)-wirth) 
nextTree' :: [Tree] -> [Tree] 
nextTree' = (parMap rseq) nextTree 
 
-- Toma una rama y la expande desde su raíz 
nextTree :: Tree -> Tree 
nextTree = deep [] 2 
  where deep xs n (Node x []) = Node x $ xpan (x:xs) n 
        deep xs n (Node x ns) = Node x $ (parMap rseq) (deep (x:xs) (n+1)) ns 
        xpan xs n = (parMap rseq) (\c -> Node c []) $ filter (\c -> chkPrefix n (c:xs)) abc 
 
-- Crea un árbol n-Wirth (con n >= 1) 
wirthTree :: Int -> [Tree] 
wirthTree n = foldl (const . nextTree') oneTree [0..n-2] 
 
-- Dado un árbol n-Wirth, genera las secuencias de longitud z 
tree2string :: Int -> [Tree] -> [String] 
tree2string z = concat . (parMap rseq) (deep [] 1) 
  where deep xs w (Node x []) = if w == z then [(x:xs)] else [] 
        deep xs w (Node x ns) = if w == z then [(x:xs)] else concat $ (parMap rseq) (deep (x:xs) (w+1)) ns 
 
-- Añadiendo un único símbolo, la secuencia es válida si no se repite consecutivamente, 
-- el primer caracter, los dos primeros caracteres, los tres ...  
chkPrefix :: Int -> String -> Bool 
chkPrefix n = not . prefixsDup (n `div` 2) 
 
-- Indica si el primer caracter se repite con el segundo, si el primero y segundo con 
-- el tercero y cuarto, el primero, segundo y tercero con el cuarto, quinto y sexto, etc... 
prefixsDup :: Int -> String -> Bool 
prefixsDup 0 _  = False 
prefixsDup n xs = prefixsDup (n - 1) xs || prefixDup n xs 
 
-- Indica si el prefijo indicado se repite consecutivamente (sólo al inicio) 
prefixDup :: Int -> String -> Bool 
prefixDup s = uncurry isPrefixOf . splitAt s 
 
-- IO 
main = do 
  (n:_) <- getArgs 
  let z    = (read n) :: Int 
      tree = wirthTree z 
  mapM_ (\n -> putStrLn $ show $ length $ tree2string n tree) [1..z] 
   
{-- 
 
Generar las 40 primeras secuencias Wirth completas en un AMD Phenom(tm) II X6 1045T (2,7 GHz)  
 
   1. algoritmo que genera la lista infinita (sin paralelizar), 40 segundos. 
 
   2. el método del árbol sin paralelizar, 16 segundos. 
 
   3. el método del árbol cambiando "map" por "(parMap rseq)", 13 segundos (mucho chunk debe haber aquí, la mejora debería ser mucho mejor). 
 
--} 

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.