2votos

Laberintos vieneses en Haskell

por josejuan hace 5 años

Implementación en Haskell de la solución aportada anteriormente.

Resolver el denominado laberinto vienés (Viennese Maze)

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
{- 
    Implementación en Haskell de la solución aportada anteriormente. 
     
    Se resuelve el desafío con las siguientes generalizaciones: 
     
    1. se admite cualquier tipo de vértice (cualquier tipo de dato). 
     
    2. se admite cualquier tipo de grafo no dirigido (no tiene porqué ser una cuadrícula). 
     
    3. el producto final permite buscar la ruta óptima desde cualquier vértice inicial a 
       cualquier vértice final en un único procesamiento (ej. usando Floyd-Warshall). 
-} 
 
 
-- El grafo final tendrá por vértices: 
data Vertex a = StartV a                -- Vértices iniciales iguales al grafo original. 
              | FinalV a                -- Vértices finales iguales al grafo original. 
              | DoubleV a Int a Int     -- Vértices que son transiciones entre vértices del grafo original. 
              deriving (Read, Show, Eq, Ord) 
 
-- Una arista ponderada con los vértices anteriores. 
data Edge a = Edge (Vertex a) (Vertex a) Int deriving (Read, Show, Eq, Ord) 
 
-- Convierte un grafo a otro que resuelve el problema de los laberintos vieneses 
genVieneseGraph :: Eq a => Graph a -> [Edge a] 
genVieneseGraph sourceG = starterG ++ withoutBacksG ++ finalG 
 
  where spaceTimeG = concatMap grow sourceG 
                     where grow (Seg x c y) = [DoubleV a i b ii | (a, b) <- [(x, y), (y, x)] 
                                                                , i <- [0..2] 
                                                                , let ii = (i + 1) `mod` 3 
                                                                , adds c i /= R ] 
 
        withoutBacksG = [ Edge av bv 1 | av@(DoubleV as  _ ad ac) <- spaceTimeG 
                                    , bv@(DoubleV bs bc bd  _) <- spaceTimeG 
                                    , ad == bs && ac == bc && as /= bd ] 
 
        sourceVertex = nub $ concatMap (\(Seg x _ y) -> [x, y]) sourceG 
        withoutBacksVertex = nub $ concatMap (\(Edge a b _) -> [a, b]) withoutBacksG 
 
        starterG = [ Edge (StartV a) b 0 | a <- sourceVertex 
                                        , b@(DoubleV as ac _ _) <- withoutBacksVertex 
                                        , a == as && ac == 0 ] 
 
        finalG = [ Edge b (FinalV a) 0 | a <- sourceVertex 
                                    , b@(DoubleV as _ _ _) <- withoutBacksVertex 
                                    , a == as ] 
 
-- Y ya está. 
 
 
 
 
 
 
 
 
-- Por ejemplo, para convertir el grafo resultante anterior a la representación usada 
-- por la solución al desafío "Dijkstra con heap" y poder usar ese algoritmo de búsqueda 
-- (http://www.solveet.com/exercises/Dijkstra-con-heap/163/solution-1175) 
graphListToMap :: Ord a => [Edge a] -> Map.Map (Vertex a) [(Vertex a, Int)] 
graphListToMap = foldl add Map.empty 
                 where add m (Edge a b p) = Map.alter (up b p) a m 
                       up b p Nothing = Just [(b, p)] 
                       up b p (Just xs) = Just $ (b, p): xs 
 
 
-- O para poder hacer una búsqueda directa de un nodo inicial a otro final y mostrar resultado 
solveFromTo g s d = shortestPath (dijkstra (StartV s) $ graphListToMap $ genVieneseGraph g) (FinalV d) 
showSolution = concat . catMaybes . map (\v -> case v of 
                                                 DoubleV x _ _ _ -> Just x 
                                                 _               -> Nothing ) . reverse 
 
 
 
 
 
-- Por otro lado y de forma independiente, pueden sobrecargarse algunos operadores para poder 
-- "dibujar" fácilmente los laberintos 
data Sem = G | O | R deriving (Read, Show, Eq) 
 
next G = O; next O = R; next R = G 
adds c i = foldr (const next) c [1..i] 
 
data Seg a = Seg { from :: a, color :: Sem, to :: a } deriving (Read, Show) 
type Graph a = [Seg a] 
 
link :: Sem -> a -> Graph a -> Graph a 
link s x xs@(Seg y _ _:_) = Seg x s y: xs 
 
infixr 7 .+ ; infixr 7 .% ; infixr 7 .- 
infixr 8 .+.; infixr 8 .%.; infixr 8 .-. 
 
(.+) = link G; (.%) = link O; (.-) = link R 
 
x .+. y = [Seg x G y]; x .%. y = [Seg x O y]; x .-. y = [Seg x R y] 
 
 
 
-- Ahora, podemos "dibujar" el laberinto del ejemplo enlazado (en la respuesta a la pregunta) como 
test = a .% b .% c .+. d ++ -- horizontal 
       e .+ f .+ g .+. h ++ 
       i .% j .+ k .%. l ++ 
       m .- n .+ o .-. p ++ 
 
       a .+ e .- i .%. m ++ -- vertical 
       b .+ f .% j .-. n ++ 
       c .- g .+ k .%. o ++ 
       d .% h .- l .-. p 
 
       where [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p] = map (:"") ['a'..'p'] 
 
{- 
     
    Y entonces resolverlo bien a ser: 
 
    *Main> showSolution $ solveFromTo test "a" "p" 
    "aeijfeijkonjfghlkjnop" 
     
-} 
5 comentarios
1votos

Escrito por JCarles hace 5 años

Genial como siempre.

Una pregunta, ¿como se simplificaría tu solución sabiendo que sólo existe un sólo camino en el laberinto? Es decir, sin buscar el camino más corto y sabiendo que no va a haber bucles "puros" (mismo vértice & mismo estado)

Juraría que por definición los laberintos vieneses tienen también esta particularidad.
0votos

Escrito por josejuan hace 5 años

Uhmm... si la única información que tenemos es que "sólo hay un camino posible" será difícil (yo no veo cómo) sacar ventaja, porque la búsqueda en el grafo hay que seguir haciéndola. Esa información sería útil si nos pidieran encontrar todas las rutas.

Por otro lado, me temo que no (si he entendido bien, claro); los laberintos vieneses pueden tener muchas rutas diferentes para llegar desde un mismo punto A a otro mismo punto B.

La prueba más sencilla es unir los puntos A y B con dos aristas, una en verde y otra en naranja, ya tenemos dos rutas y queda refutado.

También puede demostrarse por reducción al absurdo con el añadido de que nos da un procedimiento para generar laberintos vieneses arbitrariamente grandes con un número arbitrario de rutas diferentes.

1. supongamos que los laberintos vieneses tienen siempre una y sólo una ruta (los que no tienen ruta podemos descartarlos).

2. toma dos laberintos vieneses A y B (pueden ser el mismo o diferentes) y crea uno nuevo en el que los nodos iniciales de A y B serán el mismo y los nodos finales de A y B serán el mismo, ahora añade todos los nodos y aristas de A y todos los nodos y aristas de B de forma independiente. El nuevo laberinto tiene dos rutas para llegar del nodo inicial al final (la ruta que había en el laberinto A y la ruta que había en el laberinto B).

3. por [2] el nuevo laberinto tiene dos rutas, pero esto contradice [1], luego hemos demostrado que sí pueden tener más de una ruta válida para llegar del origen al destino.

(Podemos repetir [2] para tener laberintos con tantas rutas como queramos)

¡Y gracias por el desafío!, muy original :)
0votos

Escrito por JCarles hace 5 años

No me he explicado bien.

Me refería a que para que un laberinto de ese estilo sea válido, como laberinto vienés correcto, tiene que tener una y solo una ruta. Del mismo modo que un Sudoku, para que sea válido, tiene una y solo una solución.

Y en cuanto a la optimización, como usas 'shortestPath' y 'dijkstra', no sé si ello añade alguna complejidad innecesaria (lo desconozco profanamente)
0votos

Escrito por josejuan hace 5 años

¿Para que pueda llamarse "vienes" es requisito que sólo exista una ruta?, umm, curioso.

A mi no se me ocurre cómo esa información puede ayudar y de haberla (que la habrá, siempre se puede arañar algo de una información) no veo una forma fácil. Por ejemplo, es posible que haya algún invariante (útil) en cuanto a la conexión de colores de semáforos, pero suelen ser muy difíciles de caracterizar.

No, así a vuelapluma, a mí no se me ocurre ninguna vía para aprovechar esa información (pero lo que se dice nada vamos XD XD XD).
0votos

Escrito por JCarles hace 5 años

Aquí hay lo poco que hay en internet sobre este tema:

http://zulko.github.io/blog/2014/04/27/viennese-mazes-what-they-are/

Y aunque no lo especifica claramente, se deduce que sea así. Y si no es por definición, almenos lo llama "good viennese maze"

En ese artículo resuelve otro desafío de programación (si te gusta el tema, puedes plantearlo también en Solveet :), el de a partir de un grafo determinado, encontrar el laberinto vienés más interesante, según las reglas que enumera.

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.