0votos

Carrera de "¡Baja la escalera!" en Haskell

por josejuan hace 5 años

Se resuelven problemas de 22000 filas (242M nodos) en 2,68 segundos usando 8 cores. Lo que me ha gustado de este problema es que te obliga a darle muchas vueltas para obtener soluciones eficientes. Existen muchas alternativas, pero sólo unas pocas consiguen buen rendimiento. Soluciones genéricas (como usar Floyd o Dijikstra) darían rendimientos mucho menores porque este problema admite soluciones específicas.

Una variante que convierte al popular juguete en una carrera de la que debes calcular las mejores rutas de los corredores.

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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
-- Se paraleliza de forma genérica usando REPA (api de haskell para trabajar con matrices). 
 
 
-- Por comodidad creamos dos alias 
type Row = Array U DIM1 Int             -- Cada fila de un árbol. 
type Tree = [Row]                       -- Un árbol es una lista de filas. 
 
 
-- Obtener los costes mínimos de TODOS los nodos del árbol es crear uno nuevo sumando costes 
costsTree :: Monad m => Tree -> m (Row, Tree) 
costsTree (x:[]) = return (x, [x]) 
costsTree (x:xs) = do  (y, ys) <- costsTree xs 
                       z       <- x <+ y 
                       return (z, z:ys) 
 
 
-- Así, la operación básica (paralelizable) que consiste en obtener los costes supuestos los inferiores es 
(<+) :: Monad m => Row -> Row -> m Row 
a <+ b = computeP $ traverse a id best 
         where best _ z@(Z :. i) = a!z + if cL <= cR then cL else cR 
                                   where cL  = b!z 
                                         cR  = b!(Z :. (i + 1)) 
 
          
-- Y ya está. 
 
 
-- ======================================================================================= 
{- 
    Por ejemplo, dado un árbol, obtener los costes de cada corredor y el árbol de costes totales sería 
     
    *Main> sample 
    [AUnboxed (Z :. 2) (fromList   [2,0]) 
    ,AUnboxed (Z :. 3) (fromList  [1,5,0]) 
    ,AUnboxed (Z :. 4) (fromList [9,3,2,4])] 
     
    *Main> costsTree sample 
    (AUnboxed (Z :. 2) (fromList [6,2]) 
    ,[AUnboxed (Z :. 2) (fromList   [6,2]) 
     ,AUnboxed (Z :. 3) (fromList  [4,7,2]) 
     ,AUnboxed (Z :. 4) (fromList [9,3,2,4]) 
 
 
 
    Comparando la resolución de un árbol de 22.000 filas (242 millones de nodos) usando 8 cores, 
    el tiempo se reduce desde 10.92 segundos a 2.68 segundos. 
     
    c:\DATOS_OFFLINE\tmp\testing>trirepa.1.exe 2 22000 +RTS -N1 
    Leyendo a'rbol... 
    Generando aleatoriamente... 
    (forzar 99013) 
    Leido en 22.729239900014363 
    Calculando costes mi'nimos... 
    Calculado en 10.920019199955277 
    Costes mi'nimos: 
    [36204,36202] 
 
    c:\DATOS_OFFLINE\tmp\testing>trirepa.1.exe 2 22000 +RTS -N8 
    Leyendo a'rbol... 
    Generando aleatoriamente... 
    (forzar 99013) 
    Leido en 24.91324380005244 
    Calculando costes mi'nimos... 
    Calculado en 2.683204700006172 
    Costes mi'nimos: 
    [36204,36202] 
     
     
-} 
 
-- Si se desean obtener las rutas, ahora sólo hay que recorrer una vez descendentemente el árbol de costes 
findPath :: Tree -> Tree -> [[Int]] 
findPath (c:cs) (r:rs) = 
  best cs rs $ map (\i -> (i, [c!(Z :. i)])) [0..length (toList r) - 1] 
  where best [] [] ps = map snd ps 
        best (c:cs) (r:rs) ps = ps' `seq` best cs rs ps' 
                                where ps' = map idx ps 
                                      idx (i, p) = if r!i0 <= r!i1 then (i, (c!i0): p) else (i + 1, (c!i1): p) 
                                                   where i0 = Z :. i 
                                                         i1 = Z :. (i + 1) 
 
-- Es paralelizable, pero si el nº de corredores es pequeño, no merece la pena; pues el nº de operaciones es 
-- sólo el nº de filas por el nº de corredores. 
 
 
-- ===================================================== 
-- El código completo usado sería: 
{-# LANGUAGE ScopedTypeVariables #-} 
import Data.Array.Repa hiding ((++), map) 
import qualified Data.Array.Repa as R 
import Data.Vector.Unboxed.Base (Unbox) 
import System.Environment 
import System.Clock 
import Data.Bits 
import Data.Array.Repa.Algorithms.Randomish (randomishIntArray) 
 
type Row = Array U DIM1 Int 
type Tree = [Row] 
 
treeFromList :: [[Int]] -> Tree 
treeFromList [] = [] 
treeFromList (x:xs) = r: treeFromList xs 
                      where r = fromListUnboxed (Z :. length x) x 
 
treeFromRandom :: Int -> Int -> Tree 
treeFromRandom w r = map gen [w..w + r] 
                     where gen size = randomishIntArray (Z :. size) 0 9 size -- siempre usamos las mismas semillas 
 
(<+) :: Monad m => Row -> Row -> m Row 
a <+ b = computeP $ traverse a id best 
         where best _ z@(Z :. i) = a!z + if cL <= cR then cL else cR 
                                   where cL  = b!z 
                                         cR  = b!(Z :. (i + 1)) 
 
costsTree :: Monad m => Tree -> m (Row, Tree) 
costsTree (x:[]) = return (x, [x]) 
costsTree (x:xs) = do  (y, ys) <- costsTree xs 
                       z       <- x <+ y 
                       return (z, z:ys) 
 
-- si `w` es pequeño, no merece la pena paralelizar, en otro caso, se puede paralelizar también sobre `w` 
-- en cada descenso 
findPath :: Tree -> Tree -> [[Int]] 
findPath (c:cs) (r:rs) = 
  best cs rs $ map (\i -> (i, [c!(Z :. i)])) [0..length (toList r) - 1] 
  where best [] [] ps = map snd ps 
        best (c:cs) (r:rs) ps = ps' `seq` best cs rs ps' 
                                where ps' = map idx ps 
                                      idx (i, p) = if r!i0 <= r!i1 then (i, (c!i0): p) else (i + 1, (c!i1): p) 
                                                   where i0 = Z :. i 
                                                         i1 = Z :. (i + 1) 
 
_main = do 
 
  putStrLn "Leyendo a'rbol..." 
   
  t0 <- getTime Realtime 
 
  args <- getArgs 
  tree <- 
    if null args 
        then 
            do 
                putStrLn "Desde entrada estandar..." 
                getContents >>= return . treeFromList . read 
        else 
            do 
                putStrLn "Generando aleatoriamente..." 
                let (w:r:_) = map read args 
                    t = treeFromRandom w r 
                return t 
   
  putStrLn $ "(forzar " ++ show (sum $ map (!(Z :. 0)) tree) ++ ")" 
   
  t1 <- getTime Realtime 
  printTime "Leido en " t0 t1 
   
  putStrLn "Calculando costes mi'nimos..." 
   
  t2 <- getTime Realtime 
   
  (costs, tree') <- costsTree tree 
   
  t3 <- getTime Realtime 
  printTime "Calculado en " t2 t3 
   
  putStrLn "Costes mi'nimos:" 
  print $ toList costs 
 
 
diffTime :: TimeSpec -> TimeSpec -> Double 
diffTime a b = t b - t a 
  where t z = fromIntegral (sec z) + 1e-9 * fromIntegral (nsec z) 
 
printTime :: String -> TimeSpec -> TimeSpec -> IO () 
printTime msg a b = putStrLn $ msg ++ show (diffTime a b) 
1 comentario

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.