0votos

Laberinto numérico en Haskell

por josejuan hace 2 años

Lo he intentado pero no consigo mejorar el algoritmo básico de búsqueda, no se si se puede o, como la conjetura de Collatz, no se sabe aún. Tampoco he podido obtener una buena cota superior. Sin embargo, en lugar de bajar el árbol en anchura, podemos ir reduciendo la altura a la vez que vamos de un lado al otro con sólo analizar primero las reducciones exponenciales (dividir por 2 el destino). No es determinista, pero la heurística funciona bien.

Búsqueda de la longitud del camino más corto en un laberinto numérico.

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
{- 
 
  La heurística va reduciendo la cota superior, por lo que de todo 
  el árbol de posibilidades va reduciendo la altura según encuentra 
  mejores soluciones. La heurística consiste en usar la multiplicación 
  por 2 que reduce el destino en la mitad, la forma más rápida de llegar 
  o no a una solución. 
 
  Normalmente revisará más nodos que la búsqueda en anchura, pero no requiere 
  memoria (en anchura necesita guardar todo el árbol al menos, de todos los 
  nodos en el heap), por lo que la constante es mucho menor. 
 
                  *** 
                 ***** 
                *******  <-- mejor solución 
               ·····**** 
              ·······**** 
             ········***** 
            ···········**** 
           ··············*** 
          ·················** 
         ····················* 
 
-} 
 
 
 
 
 
-- Solución directa en que sólo muestra el resultado 
primMul' :: Int → Int → [Int] 
primMul' a b = snd $ execState (mejor 0 b []) (maxBound :: Int, []) 
  where mejor !s !b rs = get ↪ λq → do 
                           when (q^._1 > s ∧ b ≥ a) $ do 
                             when (a  ≡ b) $ put (s, b: rs) 
                             when (even b) $ mejor (s + 1) (b ÷ 2) (b: rs) 
                             mejor (s + 1) (b - 2) (b: rs) 
                             mejor (s + 1) (b × 2) (b: rs) 
{- 
> primMul' 3 101 
[3,6,12,24,48,50,100,200,202,101] 
(9.36 secs, 881,857,040 bytes) 
-} 
 
 
 
 
 
-- Solución más elaborada que muestra cómo se reduce la cota y cómo se 
-- alcanzan sólo unos pocos nodos de todo el árbol 
data Estado = Estado { _longitud :: !Int 
                     , _nodos    :: !Int 
                     , _solución :: [Int] } deriving Show 
makeLenses ''Estado 
 
primMul :: MonadIO m ⇒ Int → Int → m Estado 
primMul a b = execStateT (mejor 0 b []) (Estado maxBound 0 []) 
  where mejor !s !b rs = get ↪ λq → do 
                           nodos += 1 
                           when (q^.longitud > s ∧ b ≥ a) $ do 
                             when (b ≡ a) $ do 
                               io $ putStrLn $ "Cota superior en " ⧺ show s ⧺ ", " ⧺ show (q^.nodos) ⧺ " alcanzados" 
                               longitud .= s 
                               solución .= b: rs 
                             when (even b) $ mejor (s + 1) (b ÷ 2) (b: rs) 
                             mejor (s + 1) (b - 2) (b: rs) 
                             mejor (s + 1) (b × 2) (b: rs) 
 
{- 
> primMul 3 101 
Cota superior en 50, 49 alcanzados 
Cota superior en 49, 650 alcanzados 
Cota superior en 47, 2091 alcanzados 
Cota superior en 45, 3535 alcanzados 
Cota superior en 44, 4981 alcanzados 
Cota superior en 42, 9072 alcanzados 
Cota superior en 41, 13149 alcanzados 
Cota superior en 40, 22812 alcanzados 
Cota superior en 38, 23452 alcanzados 
Cota superior en 37, 27588 alcanzados 
Cota superior en 36, 37228 alcanzados 
Cota superior en 34, 37869 alcanzados 
Cota superior en 33, 42007 alcanzados 
Cota superior en 31, 53467 alcanzados 
Cota superior en 30, 65125 alcanzados 
Cota superior en 29, 92360 alcanzados 
Cota superior en 27, 94195 alcanzados 
Cota superior en 26, 105867 alcanzados 
Cota superior en 24, 138242 alcanzados 
Cota superior en 23, 171179 alcanzados 
Cota superior en 21, 247960 alcanzados 
Cota superior en 19, 249782 alcanzados 
Cota superior en 18, 261449 alcanzados 
Cota superior en 17, 293826 alcanzados 
Cota superior en 16, 293884 alcanzados 
Cota superior en 15, 326855 alcanzados 
Cota superior en 13, 403614 alcanzados 
Cota superior en 11, 405437 alcanzados 
Cota superior en 10, 417106 alcanzados 
Estado {_longitud = 10, _nodos = 422149, _solución = [3,6,12,24,48,50,100,200,202,101]} 
(13.77 secs, 1,408,449,104 bytes) 
 
-} 
 
 
 
 
{- 
 
    Por ejemplo, comparando las versiones en anchura (#1) y con heurística (#2) la 
    segunda es más rápida y usa muchísima menos memoria: 
 
josejuandespierto$ time -f "%E, %M" ../shortest 1 3 383 
[3,5,10,20,22,44,46,92,94,188,190,380,760,762,381,383] 
0:05.22, 260188 
 
josejuandespierto$ time -f "%E, %M" ../shortest 2 3 383 
[3,5,10,20,22,44,46,92,94,188,190,380,760,762,381,383] 
0:04.82, 4304 
josejuandespierto$ 
 
-} 

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.