0votos

Cifras y letras en Haskell

por josejuan hace 6 años

Generamos expresiones genéricas "polacas", luego evaluamos sobre todas las combinaciones de argumentos de entrada y operaciones válidas podando inválidas.

Dada una lista de números naturales y de operaciones binarias (suma, resta, producto y división), encontrar TODAS las expresiones que generan un número dado.

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
import Data.Maybe 
 
{-- 
  Caben muchísimas optimizaciones como: 
  1. todas las conmutativas en lugar de permutar se pueden combinar los argumentos (1+2==2+1). 
  2. evaluar todas las combinaciones mientras se generan las polacas (así se descartan según surgen). 
  3. agrupar las conmutativas en una única operación (polaca n-ária en lugar de binaria) (1+(2+3)==1+2+3). 
  4. argumentos iguales (nºs de entrada iguales) pueden eliminar permutaciones (1%1'==1'%1). 
  5. buscar invarianzas para eliminar expresiones isomorfas (2*3+1-4==3*2-4+1). 
--} 
 
-- Formas de sumar un nº con otros dos tales que el primero no es menor que el segundo. 
sums :: Int -> [(Int, Int)] 
sums n = [(n - u, u) | u <- [1..n `div` 2]] 
 
 
-- Genera todas las expresiones de calculadora polaca (leyendo por la izq) de operaciones binarias. 
trees :: Int -> [String] 
trees 1 = ["*"] 
trees 2 = ["**+"] 
trees n = concatMap subtrees $ sums n 
              where subtrees (v, u) = [a ++ b ++ "+" | a <- trees v 
                                                     , b <- trees u] 
 
-- Evalúa un árbol binario "polaco" y devuelve todas las expresiones solución 
eval :: Int                         -- Nº a buscar 
        -> [  Int    -> Int         -- Una función que dados dos nºs... 
           -> String -> String      -- ...y las expresiones que los generaron... 
           -> Maybe (Int, String)]  -- ...devuelve (si puede) el valor generado y su expresión. 
        -> String                   -- Expresión polaca genérica. 
        -> [(Int, String)]          -- Pila de valores calculados (con sus expresiones generadoras). 
        -> [Int]                    -- Lista de nºs de entrada aún no usados. 
        -> [String]                 -- Devuelve las expresiones que generan el valor buscado. 
 
eval n _ [] stack _ = if w == n then [q] -- Si la expresión da el valor buscado, tenemos nueva solución. 
                                else []  -- No vale. 
                      where (w, q) = head stack 
 
-- Aquí simplemente concatenamos todos los caminos al elegir un nº de los posibles, 
-- usamos un zipper para poder sacar rápidamente al candidato de la lista. 
eval n fn ('*':xs) stack args = evals args [] 
  where evals [a] post = eval n fn xs ((a,show a):stack) post 
        evals (a:as) post = eval n fn xs ((a,show a):stack) (as++post) ++ evals as (a:post) 
 
-- Aquí concatenamos todos los caminos al realizar todas las operaciones posibles: 
eval n fn ('+':xs) ((a,qa):(b,qb):stack) args = concatMap subEval $ mapMaybe aplicar fn 
  where subEval r = eval n fn xs (r:stack) args 
        aplicar f = f a b qa qb 
 
-- (ejemplo de uso más abajo) 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
-- Una posible lista de operaciones. 
fn :: [Int -> Int -> String -> String -> Maybe (Int, String)] 
fn = [\a b qa qb -> Just (a + b, "(" ++ qa ++ "+" ++ qb ++ ")") 
     ,\a b qa qb -> if a < b then Nothing else Just (a - b, "(" ++ qa ++ "-" ++ qb ++ ")") 
     ,\a b qa qb -> Just (a * b, "(" ++ qa ++ "*" ++ qb ++ ")") 
     ,\a b qa qb -> if b == 0 || a `mod` b /= 0 then Nothing else Just (a `div` b, "(" ++ qa ++ "/" ++ qb ++ ")") 
 
 
-- Helpers. 
treeSolutions fn xs n t = eval n fn t [] xs 
treesSolutions fn xs n = concatMap (treeSolutions fn xs n) $ trees (length xs) 
 
 
 
-- test 
main = print $ length $ treesSolutions fn [1,3,7,10,25,50] 765 
 
 
{-- 
 
Tiempos de ejecución comparados con la solución en I1M2012: 
 
   En un Intel ATOM D510: 
 
       Sin compilar (desde ghci): 
 
           *Main> length $ treesSolutions fn [1,3,7,10,25,50] 765 
           83 
           (9.10 secs, 717859248 bytes) 
           *Main> length $ treesSolutions fn [1,3,7,10,25,50] 765 
           83 
           (9.13 secs, 718088248 bytes) 
 
           *Main> length $ treesSolutions fn [1,3,7,10,25,50] 831 
           (8.78 secs, 717722112 bytes) 
           *Main> length $ treesSolutions fn [1,3,7,10,25,50] 831 
           (8.62 secs, 718182616 bytes) 
     
     
           *Main> length $ soluciones'' [1,3,7,10,25,50] 765 
           49 
           (13.99 secs, 851569640 bytes) 
           *Main> length $ soluciones'' [1,3,7,10,25,50] 765 
           49 
           (13.98 secs, 850329680 bytes) 
 
           *Main> length $ soluciones'' [1,3,7,10,25,50] 831 
           (12.61 secs, 849788736 bytes) 
           *Main> length $ soluciones'' [1,3,7,10,25,50] 831 
           (12.48 secs, 850349976 bytes) 
 
 
       Compilados con "ghc -O2": 
 
          solveet$ time -f "%E, %M" ./treesSolutions # buscando 765 
          83 
          0:00.33, 2204 
          solveet$ time -f "%E, %M" ./treesSolutions # buscando 765 
          83 
          0:00.34, 2200 
 
          solveet$ time -f "%E, %M" ./treesSolutions # buscando 831 
          0:00.34, 2180 
          solveet$ time -f "%E, %M" ./treesSolutions # buscando 831 
          0:00.33, 2180 
 
 
          solveet$ time -f "%E, %M" ./soluciones # buscando 765 
          49 
          0:00.46, 2492 
          solveet$ time -f "%E, %M" ./soluciones # buscando 765 
          49 
          0:00.46, 2488 
 
          solveet$ time -f "%E, %M" ./soluciones # buscando 831 
          0:00.48, 2484 
          solveet$ time -f "%E, %M" ./soluciones # buscando 831 
          0:00.48, 2484 
 
 
 
--} 

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.