Pathfinding en regiones 2D

Question

¿Cómo puedo encontrar una ruta más corta o casi óptima entre dos puntos donde la ruta está restringida dentro de una región 2D?

Primero, considere el siguiente paquete de líneas:

SeedRandom[1];
points = RandomPoint[Disk[], 70];
nf = Nearest[points];
lines = Line /@ Partition[points, 2];
start = First[nf[{0, -1}]];
end = First[nf[{0, 1}]];
Graphics[{lines, Blue, PointSize[Large], Point[start], Red, Point[end]}]

Para resolver esto, se podría construir una gráfica donde las intersecciones son los vértices. Sin embargo, ¿qué pasa si tenemos una combinación más complicada de regiones como la siguiente?

SeedRandom[1];
numdisks = 60;
numpolys = 40;

disks = MapThread[
   Disk[#1, #2] &, {RandomPoint[Disk[], numdisks], 
    RandomReal[1/5, numdisks]}];

polygons = MapThread[
   Translate[#1, #2] &, {RandomPolygon[8, numpolys, 
     DataRange -> {-.15, .15}], RandomPoint[Disk[], numpolys]}];

Graphics[{
  disks, polygons, PointSize[Large], Cyan, Point[{-.4, .9}], Magenta, 
  Point[{-.8, -.6}]
}]

Debería haber algún camino compuesto por segmentos de línea que nos lleve del punto cian al punto magenta. Me gustaría resolver este ejemplo en particular en un sentido agnóstico sin considerar ninguna propiedad especial de las primitivas subyacentes. En otras palabras, solo se nos da una sola región como ImageMesh[ColorNegate[Graphics[{polygons, disks}]]]y no hay forma de desglosarla más.

Answer 1

Aquí hay un enfoque que debería producir la solución óptima a nivel mundial (código a continuación):

Después de un poco de preprocesamiento, el rendimiento se puede realizar en tiempo real como se muestra en el gif. El preprocesamiento debe ejecutarse una vez para cada región, pero toma menos de 3 segundos en mi máquina para la región en cuestión.

La idea es que cada camino más corto consistirá esencialmente en líneas rectas entre puntos en el límite de la región (y, por supuesto, el punto inicial y final). Para ver esto, imagine estar en una habitación con la forma de la región, y su camino candidato más corto está marcado con una cuerda: si ahora tira de la cuerda (para minimizar la longitud de la ruta tomada por la cuerda), la cuerda se ser atrapado por algunas esquinas de la habitación, pero irá en líneas rectas en el medio. En este punto también notamos que solo se deben considerar las esquinas que apuntan hacia adentro: ningún camino más corto irá nunca a una esquina de la región que mire hacia afuera, como se puede ver nuevamente en la analogía con la cuerda.

La implementación selecciona todas las esquinas que apuntan hacia adentro pointData(que también contiene datos para la función que se insideQdescribe a continuación) y genera una lista de todas las líneas posibles entre dichos puntos, y luego selecciona las que están dentro de la región (este es el paso que tomará una mientras, ya que hay ~ 25000 líneas para verificar la región anterior). Para obtener la ruta real de principio a fin, debemos agregar todas las líneas desde esos dos puntos a cualquier punto límite que apunte hacia adentro, pero esa lista es mucho más corta y, por lo tanto, se puede calcular en tiempo real.

Lo complicado es obtener una función que pueda verificar rápidamente si una línea está dentro de la región o no; la funcionalidad de la región incorporada es demasiado lenta (y con errores), por lo que, por desgracia, necesitamos una solución personalizada.

Esto se realiza mediante las funciones lineWithinQ, intersectingQy insideQ:

• insideQcomprueba si la línea bajo prueba apunta hacia adentro desde el borde del límite calculando esencialmente el producto triple de los dos vectores de borde adjuntos y la línea en cuestión. También compilamos la función para obtener el máximo rendimiento.

• intersectingQcomprueba si la línea bajo prueba se cruza con alguna de las líneas de límite (tocar la línea no cuenta). La función resuelve eficazmente la intersección de las dos líneas (dados sus puntos finales) y verifica que la intersección sea de hecho entre los puntos finales. Para obtener el máximo rendimiento, esta función se compila y se cancela tan pronto como se encuentra una intersección.

• Finalmente, lineWithinQluego verifica si una línea está dentro de la región en dos pasos:

  • Primero, verifique si la línea apunta a la región en absoluto con insideQ
  • En segundo lugar, compruebe si la línea cruza el límite en algún punto con intersectingQ(recuerde que tocar no cuenta)

Dado que las funciones solo funcionan para líneas entre puntos en el borde, la adición del punto de inicio y final se hace de manera un poco diferente (como se ve en el manejo de starty enddentro del código de RegionShortestPathFunctionabajo): Primero filtramos líneas desde cualquier punto de límite hasta el inicio / end using lineWithinQ, ya que la función sigue funcionando siempre que el primer punto esté en el límite ( insideQcomprueba si la línea apunta a la región solo mirando desde el punto inicial de la línea). Para verificar si la línea recta de principio a fin es válida, simplemente verificamos si se cruza con el límite.

Module[
 {cond, l, i},
 cond = Unevaluated@FullSimplify[0 < t < 1 && 0 < u < 1] /. 
   First@Solve[{t, 1 - t}.{{x1, y1}, {x2, y2}} == {u, 
        1 - u}.{{x3, y3}, {x4, y4}}, {t, u}];
 cond = cond /. 
   Thread[{x1, y1, x2, y2} -> Table[Indexed[l, {i, j}], {j, 4}]];
 cond = cond /. Thread[{x3, y3} -> Table[Indexed[p1, i], {i, 2}]];
 cond = cond /. Thread[{x4, y4} -> Table[Indexed[p2, i], {i, 2}]];
 With[
  {cond = cond},
  intersectingQ = Compile @@ Hold[
     {{l, _Real, 2}, {p1, _Real, 1}, {p2, _Real, 1}},
     Module[{ret = False}, 
      Do[If[cond, ret = True; Break[]], {i, Length@l}]; ret],
     CompilationTarget -> "C", RuntimeAttributes -> {Listable}, 
     Parallelization -> True
     ]
  ]
 ]

Module[
 {cond, x1, y1, z1, x2, y2, v1, v2},
 cond = {x1, y1, z1}.Append[Normalize@{x2, y2}, 1] > 0 /. 
    Abs -> RealAbs // FullSimplify[#, x2^2 + y2^2 > 0] &;
 cond = cond /. Thread[{x1, y1, z1} -> Table[Indexed[v1, i], {i, 3}]];
 cond = cond /. Thread[{x2, y2} -> Table[Indexed[v2, i], {i, 2}]];
 insideQ = Compile @@ {
    {{v1, _Real, 1}, {v2, _Real, 1}},
    cond,
    CompilationTarget -> "C", RuntimeAttributes -> {Listable}, 
    Parallelization -> True
    }
 ]

lineWithinQ[lineData_, {{p1_, v1_}, {p2_, _}}] :=
 insideQ[v1, p2 - p1] && ! intersectingQ[lineData, p1, p2]

Options[RegionFindShortestPath] = {"MonitorProgress" -> True};

RegionFindShortestPath[region_?MeshRegionQ, start : {_, _}, end : {_, _}, opts : OptionsPattern[]] :=
 RegionFindShortestPath[region, start, opts][end]
RegionFindShortestPath[region_?MeshRegionQ, start : {_, _}, opts : OptionsPattern[]] :=
 RegionFindShortestPath[region, opts][start]

RegionFindShortestPath[region_?MeshRegionQ, OptionsPattern[]] :=
 Module[
  {lines, lineData, pointData, pathData},
  lines = MeshPrimitives[RegionBoundary@region, 1][[All, 1]];
  lineData = Catenate /@ lines;
  pointData = Cases[(* select inwards pointing corners *)
     {p_, {__, z_} /; z > 0, c_} :> {p, c}
     ]@Catenate[
     Transpose@{
         #[[All, 2]],
         Sequence @@ Table[
           Cross[#, {-1, -1, 1} #2] & @@@
            Partition[
             Append[z]@*Normalize /@ Subtract @@@ #,
             2, 1, {1, 1}
             ],
           {z, 0, 1}
           ]
         } & /@
      FindCycle[Graph[UndirectedEdge @@@ lines], \[Infinity], All]
     ];
  pathData = With[
    {expr := 
      Select[lineWithinQ[lineData, #] &]@Subsets[pointData, {2}]},
    If[OptionValue["MonitorProgress"],
      ResourceFunction["MonitorProgress"][expr, 
       "CurrentDisplayFunction" -> None],
      expr
      ][[All, All, 1]]
    ];
  RegionShortestPathFunction[pointData, lineData, 
   Join[pathData, lines]]
  ]

RegionShortestPathFunction[data__][start : {_, _}, end : {_, _}] :=
 RegionShortestPathFunction[data][start][end]
RegionShortestPathFunction[pointData_, lineData_, pathData_][start : {_, _}] :=
 RegionShortestPathFunction[pointData, lineData, Join[
   pathData,
   Select[lineWithinQ[lineData, #] &][{#, {start, {}}} & /@ 
      pointData][[All, All, 1]]
   ], start]

RegionShortestPathFunction[pointData_, lineData_, pathData_, start_][end : {_, _}] :=
 With[
  {allLines = Join[
     pathData,
     Select[lineWithinQ[lineData, #] &][{#, {end, {}}} & /@ 
        pointData][[All, All, 1]],
     If[! intersectingQ[lineData, start, end], {{start, end}}, {}]
     ]},
  Quiet@
   Check[
    FindShortestPath[
     Graph[UndirectedEdge @@@ allLines, 
      EdgeWeight -> EuclideanDistance @@@ allLines], start, end],
    {}
    ]
  ]

summaryBoxIcon = Graphics[
  {{[email protected], 
    Polygon@{{0, 0}, {0, 1}, {1, 1}, {1, -1}, {-2, -1}, {-2, 
       1.5}, {-1, 1.5}, {-1, 0}}}, {Red, 
    Line@{{0.5, 0.5}, {0, 0}, {-1, 0}, {-1.5, 1}}}, 
   AbsolutePointSize@4, Point[{0.5, 0.5}], {Point[{-1.5, 1}]}}, 
  Background -> GrayLevel[0.93], PlotRangePadding -> Scaled[0.1], 
  FrameStyle -> Directive[Thickness[Tiny], [email protected]], 
  ElisionsDump`commonGraphicsOptions
  ]

MakeBoxes[
  f : RegionShortestPathFunction[pointData_, lineData_, pathData_, 
    start_ | PatternSequence[]], fmt_] ^:=
 BoxForm`ArrangeSummaryBox[
  RegionShortestPathFunction,
  f,
  summaryBoxIcon,
  {
   BoxForm`SummaryItem@{"Corner points: ", Length@lineData},
   BoxForm`SummaryItem@{"Start set: ", Length@{start} > 0}
   },
  {
   BoxForm`SummaryItem@{"Possible segments: ", Length@pathData}
   },
  fmt
  ]

SeedRandom[1];
numdisks = 60;
numpolys = 40;

disks = MapThread[
   Disk[#1, #2] &, {RandomPoint[Disk[], numdisks], 
    RandomReal[1/5, numdisks]}];
translatePoly[poly_, pos_] := 
  Polygon[# + pos & /@ poly[[1]], poly[[2]]];
polygons = 
  MapThread[
   translatePoly[#1, #2] &, {RandomPolygon[8, numpolys, 
     DataRange -> {-.15, .15}], RandomPoint[Disk[], numpolys]}];
start = {-.4, .9};
end = {-.8, -.6};
Graphics[{disks, polygons, PointSize[Large], Cyan, Point[start], 
  Magenta, Point[end]}]
mesh = DiscretizeRegion[RegionUnion[Join[polygons, disks]]];

spf = RegionFindShortestPath[mesh]

Manipulate[
 Show[
   mesh,
   Graphics[{Thick, Red, Dynamic@Line@spf[p1, p2]}]
  ],
 {p1, Locator},
 {p2, Locator}
 ]

Como se demostró, la función se puede usar como RegionFindShortestPath[mesh][start,end](donde RegionFindShortestPath[mesh]da un RegionShortestPathFunctioncon la información precalculada almacenada en caché en su interior). Todas las combinaciones como RegionFindShortestPath[mesh,start,end]y RegionFindShortestPath[mesh,start][end]funcionan también, con la mayor cantidad de información posible almacenada en caché.

Answer 2

Se me ocurrió una solución poco convencional e ineficiente que puede ser susceptible a problemas de mallado y sensible al tamaño de la celda de malla, pero creo que produce un camino corto razonablemente bueno. Quizás otros podrían mejorar esto o sugerir soluciones alternativas:

SeedRandom[1];
numdisks = 60;
numpolys = 40;

disks = MapThread[
   Disk[#1, #2] &, {RandomPoint[Disk[], numdisks], 
    RandomReal[1/5, numdisks]}];
translatePoly[poly_, pos_] := 
  Polygon[# + pos & /@ poly[[1]], poly[[2]]];
polygons = 
  MapThread[
   translatePoly[#1, #2] &, {RandomPolygon[8, numpolys, 
     DataRange -> {-.15, .15}], RandomPoint[Disk[], numpolys]}];
start = {-.4, .9};
end = {-.8, -.6};
Graphics[{disks, polygons, PointSize[Large], Cyan, Point[start], 
  Magenta, Point[end]}]
mesh = DiscretizeRegion[RegionUnion[Join[polygons, disks]]];

cells = MeshCells[mesh, 2][[All, 1]];
prims = MeshPrimitives[mesh, 2];
meshcentroids = RegionCentroid /@ prims;
nprim = Nearest[meshcentroids -> "Index"];
startcell = cells[[First[nprim[start]]]];
endcell = cells[[First[nprim[end]]]];
connectedCells[cells1_, cells2_] := 
 Length[Intersection[cells1, cells2]] == 2
cellGr = RelationGraph[connectedCells[#1, #2] &, cells, 
   VertexCoordinates -> meshcentroids];
path = FindShortestPath[cellGr, startcell, endcell];

Show[Graphics[
  {EdgeForm[LightRed], FaceForm[LightYellow], mesh, PointSize[Large], 
   Cyan, Point[start], Magenta, Point[end]}
  ], HighlightGraph[cellGr, PathGraph[path]]
 ]

El código anterior encuentra una ruta en el gráfico de conectividad de malla. Ese es el gráfico de triángulos adyacentes (que comparten un borde) en la malla discretizada. Esta ruta es obviamente muy ondulada, por lo que el siguiente código intenta encontrar los 'saltos' más largos a lo largo de la ruta que pueden omitir vértices pero permanecer dentro de la región:

(** from the currentPoint, try to draw a line that to the furthest 
  possible point on the path that stays within the region **)
getcoords[cell_] := AnnotationValue[{cellGr, cell}, VertexCoordinates]
pathcoords = Join[{start},getcoords /@ path, {end}];
maxiline[currentPoint_, coords_] := 
 SelectFirst[Reverse[coords], 
  Quiet[Check[RegionWithin[mesh, Line[{currentPoint, #}]], False]] &]
lpath = NestWhileList[maxiline[#, pathcoords] &, start, # != end &];
Graphics[{mesh, Red, Line[lpath], PointSize[Large], Cyan, 
  Point[start], Magenta, Point[end]}]

Answer 3

aquí hay un primer intento. Se puede mejorar, pero hay que empezar por algún lado. El siguiente programa toma una región, un punto inicial y final y un tamaño de paso. Hace un gráfico de la ruta (rojo) y los puntos probados (verde). Pero tome el coche, porque no hay condiciones previas para explotar, se necesitan muchos pasos. Es un programa recursivo, por lo que necesitamos ampliar "$ RecursionLimit". Tenga cuidado con el "tamaño del paso", hágalo tan grande como sea razonable, de lo contrario el número de pasos se disparará. Además, la diferencia en las coordenadas xey entre el punto inicial y el final debe ser un múltiplo del tamaño del paso. De lo contrario, nunca se encuentra el final. Y por simplicidad, el punto de inicio debe elegirse por encima del punto final. Tenga en cuenta también que la ruta puede ser bastante grande, por lo que no tiene sentido imprimirla. La idea es que harás algo con él además de imprimir.Además, necesitará alguna región real, no polígonos traducidos, que funcionará con "RegionMember". Aquí está el programa, diviértete:

getPath[region_, start_, end_, stepsize_] := 
  Module[{path = {pos = start}, step = stepsize, wrong = {}, remem, 
    search},
   If[Mod[(end - start)/step, 1] != {0, 0}, 
    Print["Difference between end and start must be a multiple of \
stepsize."]; Return[]];
   remem = RegionMember[region];
   search[pos_] := Module[{},
     If[ Norm[pos - end] < 0.001, Return[{}]];
     Which[
      tp = 
       pos + {0, -1} step;  ( ! MemberQ[path, tp]) && ( ! 
         MemberQ[wrong, tp]) && remem[tp], AppendTo[path, tp]; 
      search[tp],
      tp = 
       pos + {1, 0} step ;  ( ! MemberQ[path, tp]) && ( ! 
         MemberQ[wrong, tp]) && remem[tp], AppendTo[path, tp]; 
      search[tp],
      tp = 
       pos + {-1, 0} step; ( ! MemberQ[path, tp]) && ( ! 
         MemberQ[wrong, tp]) && remem[tp], AppendTo[path, tp];  
      search[tp],
      True, AppendTo[wrong, path[[-1]]];  path = Delete[path, -1]; 
      If[path == {}, Return[{}]]; search[path[[-1]]];
      ]];
   search[start];
   Show[Region[region], 
     Graphics[{Green, Point[wrong], Thick, Red, Line[path], Black, 
       PointSize[0.03], Point[end] , Point[start]}], 
     PlotRange -> {{-1, 4}, {-1, 5}}, Axes -> True] // Print;
   path
   ];

Creamos una región arbitraria, elegimos un punto inicial y final y dejamos que el programa busque una ruta.

region = RegionUnion[Disk[{0, 3.2}], Disk[{0.9, 2.2}, 0.5], 
   Disk[{1.9, 3.}, 0.8], Disk[{2.5, 1.8}, 0.6], Disk[{1.8, .6}, .9], 
   Disk[{0, 0}]];
start = {0., 3.2};
end = {0, 0};
stepsize = 1/10;
$RecursionLimit = 10^4;
path = getPath[region, start, end, stepsize];

Answer 4

Empiece con esto:

RegionUnion[Disk[{0, 0}, 2], Disk[{3, 0}, 2]];

Region[%]

Para un círculo simple y un punto:

RegionDistance[Disk[{0, 0}, 2], {3, 0}]

1

Graphics[{Disk[{0, 0}, 2], Point[{3, 0}], Red, 
  Line[{{0, 0}, {3, 0}}]}]

Si la intención principal sigue siendo trabajar con Randomfunción, las ideas de @flinty no están mal para ver si están conectadas y existe un camino.

Este es el enfoque generado para una disposición geométrica plana de Circley Polygon. Para cada uno se conoce el centro y Sortse hace fácilmente una o bien.

Este proceso debe repetirse con cuidado para cada conjunto más pequeño que funcione.

Tratar con Transformfalla BooleanRegion.

ℜpolygon = 
 Region@RegionUnion[
   Table[Polygon[
     Plus[cent[[i]], #] & /@ RandomReal[{-0.15, 0.15}, {8, 2}]], {i, 
     30}]]
ℜcircle = 
 Region@RegionUnion[
   MapThread[
    Disk[#1, #2] &, {RandomPoint[Disk[], numdisks], 
     RandomReal[1/5, numdisks]}]]

ℜcomp = 
 Region@RegionUnion[ℜpolygon, ℜcircle]

Pero RegionNearest y RegionDistance no funcionan, no están definidos para BooleanRegion.

RegionDistance[
 Region@RegionUnion[{Disk[{0, 0}, 2], Disk[{1, 1}, 2], 
    Disk[{1, -1}, 2]}], {3, 0}]

Graphics[{Disk[{0, 0}, 2], Disk[{1, 1}, 2], Disk[{1, -1}, 2], 
  Point[{3, 0}], Red, 
  Line[{{Sqrt[(3/2 + 1/10 (-5 - 4 Sqrt[5]))^2 + (-3 + 
        1/5 (5 + 4 Sqrt[5]))^2], 0}, {3, 0}}]}]

Esto también debe ser un BooleanRegion.

Mathematica V12 tiene incorporado RandomInstanceyGeometricScene

RandomInstance[GeometricScene[{a, b, c, d, g, e, f}, {
   a == {-1/2, 0}, b == {1/2, 0}, Line[{f, a, b, e}],
   p0 == Polygon[{e, g, f}],
   p1 == Style[Polygon[{a, c, b}], Yellow],
   p2 == Style[Polygon[{b, d, c}], Magenta],
   p3 == Style[Polygon[{d, c, g}], Green],
   p4 == Style[Polygon[{g, c, a}], Blue],
   p5 == Style[Polygon[{e, b, d}], Purple],
   p6 == Style[Polygon[{g, a, f}], Orange],
   GeometricAssertion[{p0, p1, p2, p3, p4, p5, p6}, "Similar"]}], 
 RandomSeeding -> 4]

Tiene incorporado GeometricAssertioncon ofrece un proceso generativo para construir el camino junto con los objetos. Y esto permite polígonos aleatorios más bonitos y realistas. Y proporciona una descripción de las trayectorias en el plano y maneja relaciones más geométricas, es decir SimplePolygonQ.

El empalme podría reintroducirse en V12.1 y posteriores. Puedo encontrarme en otras respuestas a preguntas sobre esta comunidad. Secuencia @@ estilo antiguo.

AnnotationValueno está en mi documentación de Mathematica V12.0.0. Pero AnnotationValuefunciona en V12.0.0. Así que este es un elemento incorporado sin valor en esta pregunta: Falló.

Entonces el resto no funciona.

Esto funciona en V12.0.0 y similares:

Show[Graphics[{mesh, PointSize[Large], Cyan, Point[start], Magenta, 
   Point[end]}], Subgraph[cellGr, PathGraph[path]]]

Utilizando

connectedCells[cells1_, cells2_] := 
 Length[Intersection[cells1, cells2]] == 1

en el código de uso anterior da:

Show[Graphics[{mesh, PointSize[Large], Cyan, Point[start], Magenta, 
   Point[end]}], 
 Subgraph[cellGr, PathGraph[path], EdgeStyle -> {Thick, Green}]]

Esto es más rápido, pero aún tiene problemas en la parte inferior izquierda del archivo DiscretizeRegion.

mesh = DiscretizeRegion [RegionUnion [Join [polygons, disks]], MaxCellMeasure -> 1]

mesh = DiscretizeRegion[RegionUnion[Join[polygons, disks]], 
   MaxCellMeasure -> {"Length" -> 1/15}, PrecisionGoal -> None];
cells = MeshCells[mesh, 2][[All, 1]];
prims = MeshPrimitives[mesh, 2];
meshcentroids = RegionCentroid /@ prims;
nprim = Nearest[meshcentroids -> "Index"];
startcell = cells[[First[nprim[start]]]];
endcell = cells[[First[nprim[end]]]];
connectedCells[cells1_, cells2_] := 
 Length[Intersection[cells1, cells2]] == 1
cellGr = RelationGraph[connectedCells[#1, #2] &, cells, 
   VertexCoordinates -> meshcentroids];
path = FindShortestPath[cellGr, startcell, endcell];

Show[Graphics[{mesh, PointSize[Large], Cyan, Point[start], Magenta, 
   Point[end]}], Subgraph[cellGr, PathGraph[path]]]

Esto muestra que la malla adaptativa debe ser reemplazada por una malla fina de densidad regular para obtener la ruta más óptima si se utiliza la triangularización. Cada rincón, cada traspaso más pequeño, cada extensión que apunta hacia adentro o hacia afuera atrae la malla de triangulación e induce una oscilación en los caminos más cortos.

Un regular conduce a oscilaciones siempre que la medida de la celda sea alta. Para una vez más pequeña, la más corta deja de oscilar y se vuelve directa y permanece dentro de la mancha mallada. Si se tuviera mejor en cuenta el límite, el más corto podría permanecer más en la región central de las manchas.

Es un compromiso entre el tiempo y la dirección de lo corto que será el camino más corto.