opciones - Haskell: calcular el camino más corto usando árboles

multiplos en haskell

Question

Estoy tratando de escribir un código en haskell, que va del punto A al punto F, en un juego de mesa, que es esencialmente una matriz, siguiendo el camino más corto.

Este es el tablero:

AAAA
ACCB
ADEF
*
0 0 N

El robot entra en la letra A, en la parte inferior (donde es el *), y debe llegar a F, en la parte inferior del tablero están las coordenadas, x = 0, y = 0, y apuntando hacia el norte. La coordenada F es (3,0)

El truco es que no puede saltar más de una letra, puede ir de A a B, de B a C, etc. y puede recorrer las letras del tipo (A a A, B a B, etc.)

Solo puede avanzar y girar (Izquierda, derecha), así que la ruta para dejarme ir a F sería

Adelante, Adelante, Derecha, Adelante, Adelante, Adelante, Derecha, Salto, Derecha, Salto, Adelante, Izquierda, Salto, Izquierda, Adelante, Adelante

Una vez que alcanza F, ya está hecho.

Quiero probar este enfoque, usando un árbol

                  A
                 / /
                A   D
               / / 
              /   /
             A     C
            / /   / /
           /   / D   C
          A     
         / /  
        /   / 
       A
      /
     /
    A
   / /
  B   A
 / /  
C   F 

Después de eso, solo necesitaría validar el camino correcto y el derecho más corto.

El problema es que no tengo mucha experiencia usando árboles.

¿Indicaría alguna otra forma de obtener el mejor camino?

Muchas gracias .

Answer 1

Vamos a resolver este problema buscando un árbol en tres partes. Primero construiremos un Tree represente los caminos a través del problema, con ramas para cada estado. Nos gustaría encontrar el camino más corto para llegar a un estado con ciertos criterios, por lo que vamos a escribir una primera búsqueda de ancho para buscar cualquier Tree . Esto no será lo suficientemente rápido para el problema de ejemplo que proporcionó, por lo que mejoraremos en la primera búsqueda de amplitud con una tabla de transposición que realiza un seguimiento de los estados que ya hemos explorado para evitar explorarlos de nuevo.

Construyendo un árbol

Data.Array que su tablero de juego está representado en una Array de Data.Array

import Data.Array

type Board = Array (Int, Int) Char

board :: Board
board = listArray ((1,1),(3,4)) ("AAAA" ++ "ACCB" ++ "ADEF")

Data.Array no proporciona una forma predeterminada fácil de asegurarse de que los índices que buscamos valores sean Data.Array ! en realidad están dentro de los límites de la Array . Para su comodidad, proporcionaremos una versión segura que devuelve Just v si el valor está en la Array o Nothing caso contrario.

import Data.Maybe

(!?) :: Ix i => Array i a -> i -> Maybe a
a !? i = if inRange (bounds a) i then Just (a ! i) else Nothing

El State del rompecabezas puede representarse mediante la combinación de una position del robot y la direction que se enfrenta el robot.

data State = State {position :: (Int, Int), direction  :: (Int, Int)}
    deriving (Eq, Ord, Show)

La direction es un vector unitario que se puede agregar a la position para obtener una nueva position . Podemos rotar el vector de dirección hacia la left o hacia la right y moveTowards adelante.

right :: Num a => (a, a) -> (a, a)
right (down, across) = (across, -down)

left ::  Num a => (a, a) -> (a, a)
left (down, across) = (-across, down)

moveTowards :: (Num a, Num b) => (a, b) -> (a, b) -> (a, b)
moveTowards (x1, y1) (x2, y2) = (x1 + x2, y1 + y2)

Para explorar una junta, necesitaremos poder determinar desde un estado qué movimientos son legales. Para hacer esto, sería útil nombrar los movimientos, por lo que crearemos un tipo de datos para representar los movimientos posibles.

import Prelude hiding (Right, Left)

data Move = Left | Right | Forward | Jump
    deriving (Show)

Para determinar qué movimientos son legales en un tablero, necesitamos saber qué Board estamos usando y el State del robot. Esto sugiere que el tipo se moves :: Board -> State -> Move , pero vamos a calcular el nuevo estado después de cada movimiento solo para decidir si el movimiento fue legal, por lo que también le devolveremos el nuevo estado para mayor comodidad.

moves :: Board -> State -> [(Move, State)]
moves board (State pos dir) =   
    (if inRange (bounds board) pos then [(Right,   State pos    (right dir)), (Left, State pos (left dir))] else []) ++
    (if next == Just here          then [(Forward, State nextPos dir)] else []) ++
    (if next == Just (succ here)   then [(Jump,    State nextPos dir)] else [])
    where
        here = fromMaybe ''A'' (board !? pos)
        nextPos = moveTowards dir pos
        next = board !? nextPos

Si estamos en el tablero, podemos girar a la Left y a la Right ; la restricción que estamos en el tablero garantiza que todos los State devueltos por moves tienen position que están en el tablero. Si el valor se mantiene en el nextPos , la posición next coincide con lo que está Just here podemos ir Forward (si estamos fuera del tablero, suponemos que lo que está here es ''A'' ). Si el next es Just el sucesor de lo que está here , podemos Jump a él. Si el next es fuera de la pizarra, es Nothing y no puede coincidir con Just here o Just (succ here) .

Hasta este punto, acabamos de proporcionar la descripción del problema y no hemos tratado de responder la pregunta con el árbol. Vamos a utilizar el árbol de la rosa del árbol definido en Data.Tree .

data Tree a = Node {
        rootLabel :: a,         -- ^ label value
        subForest :: Forest a   -- ^ zero or more child trees
    }

type Forest a = [Tree a]

Cada nodo de un Tree a tiene un solo valor a y una lista de ramas que son cada uno un Tree a .

Vamos a construir una lista de Tree s de manera directa desde nuestra función de moves . Vamos a hacer que cada resultado de moves la rootLabel de un Node y hacer que las ramas sean la lista de Tree que obtenemos cuando explore el nuevo estado.

import Data.Tree

explore :: Board -> State -> [Tree (Move, State)]
explore board = map go . moves board
    where
        go (label, state) = Node (label, state) (explore board state)

En este punto, nuestros árboles son infinitos; nada impide que el robot gire sin cesar en su lugar ... No podemos dibujar uno, pero podríamos si limit el árbol a solo unos pocos pasos.

limit :: Int -> Tree a -> Tree a
limit n (Node a ts)
    | n <= 0    = Node a []
    | otherwise = Node a (map (limit (n-1)) ts)

Mostraremos solo los primeros dos niveles del árbol cuando comencemos desde la esquina inferior izquierda hacia la pizarra en State (4, 1) (-1, 0) .

(putStrLn .
 drawForest .
 map (fmap (/(m, s) -> show (m, board ! position s)) . limit 2) .
 explore board $ State (4, 1) (-1, 0))

(Forward,''A'')
|
+- (Right,''A'')
|  |
|  +- (Right,''A'')
|  |
|  `- (Left,''A'')
|
+- (Left,''A'')
|  |
|  +- (Right,''A'')
|  |
|  `- (Left,''A'')
|
`- (Forward,''A'')
   |
   +- (Right,''A'')
   |
   +- (Left,''A'')
   |
   `- (Forward,''A'')

Breadth First Search

La primera búsqueda de amplitud explora todas las posibilidades en un nivel (a través de la "amplitud" de lo que se está buscando) antes de descender al siguiente nivel (a la "profundidad" de lo que se está buscando). La primera búsqueda de amplitud encuentra el camino más corto hacia un objetivo. Para nuestros árboles, esto significa explorar todo en una capa antes de explorar cualquiera de lo que hay en las capas internas. Lo lograremos haciendo una cola de nodos para explorar agregando los nodos que descubrimos en la siguiente capa hasta el final de la cola. La cola siempre mantendrá los nodos de la capa actual seguidos por los nodos de la siguiente capa. Nunca mantendrá ningún nodo de la capa más allá porque no descubriremos esos nodos hasta que hayamos pasado a la siguiente capa.

Para implementar eso, necesitamos una cola eficiente, entonces usaremos una secuencia de Data.Sequence /

import Data.Sequence (viewl, ViewL (..), (><))
import qualified Data.Sequence as Seq

Comenzamos con una cola vacía Seq.empty de nodos para explorar y una ruta vacía [] dentro de los Tree s. Agregamos las posibilidades iniciales al final de la queue con >< (concatenación de secuencias) y go . Vemos el comienzo de la queue . Si no queda nada, EmptyL , no encontramos un camino hacia la meta y devolvemos Nothing . Si hay algo allí y coincide con la meta p , devolvemos el camino que hemos acumulado al revés. Si lo primero de la cola no coincide con el objetivo, lo agregamos como la parte más reciente de la ruta y agregamos todas sus ramas al resto de lo que se puso en la queued .

breadthFirstSearch :: (a -> Bool) -> [Tree a] -> Maybe [a]
breadthFirstSearch p = combine Seq.empty []
    where
        combine queue ancestors branches =
            go (queue >< (Seq.fromList . map ((,) ancestors) $ branches))
        go queue =
            case viewl queue of
                EmptyL -> Nothing
                (ancestors, Node a bs) :< queued ->
                    if p a
                    then Just . reverse $ a:ancestors
                    else combine queued (a:ancestors) bs

Esto nos permite escribir nuestro primer solve para Board s. Aquí es conveniente que todas las posiciones devueltas de moves estén en el tablero.

solve :: Char -> Board -> State -> Maybe [Move]
solve goal board = fmap (map fst) . breadthFirstSearch ((== goal) . (board !) . position . snd) . explore board

¡Si ejecutamos esto para nuestro tablero, nunca termina! Bueno, eventualmente lo hará, pero la parte posterior de un cálculo de servilleta sugiere que tomará unos 40 millones de pasos. El camino hasta el final del laberinto tiene 16 pasos de largo y al robot se le presentan con frecuencia 3 opciones de qué hacer en cada paso.

> solve ''F'' board (State (4, 1) (-1, 0))

Podemos resolver acertijos mucho más pequeños como

AB
AC
*

Que podemos representar al tablero para este rompecabezas con

smallBoard :: Board
smallBoard = listArray ((1,1),(2,2)) ("AB" ++ "AC")

Lo solve buscando ''C'' comenzando en la fila 3 columna 1 mirando hacia las filas numeradas más bajas.

> solve ''C'' smallBoard (State (3, 1) (-1, 0))
Just [Forward,Forward,Right,Jump,Right,Jump]

Tabla de transposición

Ciertamente, este problema debe ser más fácil de resolver que explorar 40 millones de caminos posibles. La mayoría de esos caminos consisten en girar en el lugar o serpenteando aleatoriamente de un lado a otro. Las rutas degeneradas comparten una propiedad, siguen visitando estados que ya han visitado. En el código breadthFirstSeach , esas rutas siguen agregando los mismos nodos a la cola. Podemos deshacernos de todo este trabajo adicional simplemente recordando los nodos que ya hemos visto.

Recordaremos el conjunto de nodos que ya hemos visto con un Set de Data.Set .

import qualified Data.Set as Set

A la firma de breadthFirstSearch agregaremos una función de la etiqueta para un nodo a una representación para las ramas de ese nodo. La representación debe ser igual siempre que todas las ramas fuera del nodo sean iguales. Para comparar rápidamente las representaciones en tiempo O(log n) con un Set , requerimos que la representación tenga una instancia Ord lugar de solo igualdad. La instancia de Ord permite a Set verificar la membresía con búsqueda binaria .

breadthFirstSearchUnseen:: Ord r => (a -> r) -> (a -> Bool) -> [Tree a] -> Maybe [a]

Además de realizar un seguimiento de la queue , breadthFirstSearchUnseen realiza un seguimiento del conjunto de representaciones que se han seen , comenzando con Set.empty . Cada vez que agregamos ramas a la queue con combine también agregamos las representaciones a seen . Solo agregamos las ramas unseen cuyas representaciones no están en el conjunto de ramas que ya hemos seen .

breadthFirstSearchUnseen repr p = combine Set.empty Seq.empty []
    where
        combine seen queued ancestors unseen =
            go
                (seen  `Set.union` (Set.fromList . map (repr . rootLabel) $ unseen))
                (queued ><         (Seq.fromList . map ((,) ancestors   ) $ unseen))
        go seen queue =
            case viewl queue of
                EmptyL -> Nothing
                (ancestors, Node a bs) :< queued ->
                    if p a
                    then Just . reverse $ ancestors''
                    else combine seen queued ancestors'' unseen
                    where
                        ancestors'' = a:ancestors
                        unseen = filter (flip Set.notMember seen . repr . rootLabel) bs

Ahora podemos mejorar nuestra función de solve para usar breadthFirstSearchUnseen . Todas las ramas de un nodo están determinadas por el State ; la etiqueta Move que llegó a ese estado es irrelevante, por lo que solo usamos la parte snd de la tupla (Move, State) como la representación de un nodo.

solve :: Char -> Board -> State -> Maybe [Move]
solve goal board = fmap (map fst) . breadthFirstSearchUnseen snd ((== goal) . (board !) . position . snd) . explore board

Ahora podemos solve el rompecabezas original muy rápidamente.

> solve ''F'' board (State (4, 1) (-1, 0))
Just [Forward,Forward,Forward,Right,Forward,Forward,Forward,Right,Jump,Right,Jump,Forward,Left,Jump,Left,Jump,Jump]