Re: Isometrische 2D Spiele-Engine
Verfasst: 18.03.2019 14:18
Ist noch ein Themadiceman hat geschrieben:Ist das mit der A*-Pfadsuche noch ein Thema?
Frage nur, weil ich hätte eine entsprechende Funktion vorliegen, die ich mal in Blitzbasic programmiert, und dann auch erfolgreich nach PureBasic übersetzt habe. Läuft flott und fehlerfrei. Alles was die Funktion braucht, ist ein Array vom entsprechenden Level, welches mit mit Nullen (Mauern/Hindernisse) und Einsen (frei) gefüllt ist.
Benötige ich noch immer, vor kurzem habe ich mich mal daran versucht bin aber noch nicht erfolgreich gewesen.
Der Algo findet nicht immer das Ziel - verm. ist der rekursive Suchlauf fehlerbehaftet.
Würde mich freuen wenn ich deine Funktionen verwenden dürfte.
Gerne aber stelle ich auch meinen Code ein eventuell kann der ja gefixt werden (war da ratlos am Ende).
Hier der Code:
Code: Alles auswählen
EnableExplicit
;ASTAR TYPE PATHFINDING
;Version: DRAFT
;Author: Mijikai
Structure ASTAR_OFFSET_STRUCT
x.i
y.i
EndStructure
Structure ASTAR_LINK_STRUCT
*child.ASTAR_NODE_STRUCT
cost.i
EndStructure
Structure ASTAR_NODE_STRUCT
offset.ASTAR_OFFSET_STRUCT
*parent.ASTAR_NODE_STRUCT
links.i
Array link.ASTAR_LINK_STRUCT(7)
EndStructure
Structure ASTAR_MASK_STRUCT
*buffer
size.i
width.i
height.i
EndStructure
Structure ASTAR_STRUCT
mask.ASTAR_MASK_STRUCT
start.ASTAR_OFFSET_STRUCT
stop.ASTAR_OFFSET_STRUCT
*path.ASTAR_NODE_STRUCT
List node.ASTAR_NODE_STRUCT()
EndStructure
Global *dummy
Global position.ASTAR_OFFSET_STRUCT
Macro astar_Equal(X1,Y1,X2,Y2)
Bool(X1 = X2 And Y1 = Y2)
EndMacro
Macro astar_Valid(X1,Y1,X2,Y2,Width,Height)
Bool(Not X1 < 0 And
Not Y1 < 0 And
Not X2 < 0 And
Not Y2 < 0 And
X1 < Width And
Y1 < Height And
X2 < Width And
Y2 < Height)
EndMacro
Procedure.i astar_Distance(X1.i,Y1.i,X2.i,Y2.i)
Protected dx.i
Protected dy.i
dx = Abs(X1 - X2)
dy = Abs(Y1 - Y2)
If dx > dy
ProcedureReturn (dx + dy) + (dx >> 1)
Else
ProcedureReturn (dx + dy) + (dy >> 1)
EndIf
EndProcedure
Procedure.i astar_Check(*astar.ASTAR_STRUCT,X.i,Y.i)
Protected *ptr.Ascii
With *astar
If Not X < 0 And Not Y < 0 And X < \mask\width And Y < \mask\height
*ptr = \mask\buffer + X + (Y * \mask\width)
ProcedureReturn *ptr\a
Else
ProcedureReturn #True
EndIf
EndWith
EndProcedure
Procedure.i astar_Mark(*astar.ASTAR_STRUCT,X.i,Y.i,Flag.b)
Protected *ptr.Ascii
With *astar
*ptr = \mask\buffer + X + (Y * \mask\width)
*ptr\a = Flag
EndWith
EndProcedure
Procedure.i astar_Child(*astar.ASTAR_STRUCT,*node.ASTAR_NODE_STRUCT,Index.i,X.i,Y.i)
With *astar
If astar_Check(*astar,X,Y) = #Null
If astar_Equal(X,Y,\start\y,\start\x)
\path = *node
EndIf
If AddElement(\node())
\node()\parent = *node
\node()\offset\x = X
\node()\offset\y = Y
*node\link(Index)\child = @\node()
*node\link(Index)\cost = astar_Distance(X,Y,\stop\x,\stop\y)
*node\links + 1
ProcedureReturn #True
EndIf
EndIf
EndWith
EndProcedure
Procedure.i astar_Parent(*astar.ASTAR_STRUCT,*node.ASTAR_NODE_STRUCT)
Protected index.i
Protected *next.ASTAR_NODE_STRUCT
With *astar
If \path
ProcedureReturn #Null
EndIf
astar_Child(*astar,*node,0,*node\offset\x - 1,*node\offset\y)
astar_Child(*astar,*node,1,*node\offset\x + 1,*node\offset\y)
astar_Child(*astar,*node,2,*node\offset\x ,*node\offset\y - 1)
astar_Child(*astar,*node,3,*node\offset\x ,*node\offset\y + 1)
astar_Child(*astar,*node,4,*node\offset\x - 1,*node\offset\y - 1)
astar_Child(*astar,*node,5,*node\offset\x + 1,*node\offset\y - 1)
astar_Child(*astar,*node,6,*node\offset\x - 1,*node\offset\y + 1)
astar_Child(*astar,*node,7,*node\offset\x + 1,*node\offset\y + 1)
astar_Mark(*astar,*node\offset\x,*node\offset\y,#True)
If *node\links
SortStructuredArray(*node\link(),#PB_Sort_Descending,OffsetOf(ASTAR_LINK_STRUCT\cost),#PB_Integer)
!@@:
For index = 0 To 7
If *node\link(index)\child
*next = *node\link(index)\child
*node\link(index)\child = #Null
;Debug Str(*next\offset\x) + " x " + Str(*next\offset\y)
astar_Parent(*astar,*next)
ProcedureReturn #Null
EndIf
Next
EndIf
If *node
If *node\parent
astar_Mark(*astar,*node\offset\x,*node\offset\y,#False)
*node = *node\parent
If *node\parent
*node = *node\parent
EndIf
!jmp @b
EndIf
EndIf
EndWith
EndProcedure
Procedure.i astar_Task(X1.i,Y1.i,X2.i,Y2.i,*Buffer,Width.i,Height.i)
Protected *astar.ASTAR_STRUCT
If *Buffer And Width > 0 And Height > 0
If Not astar_Equal(X1,Y1,X2,Y2)
If astar_Valid(X1,Y1,X2,Y2,Width,Height)
*astar = AllocateStructure(ASTAR_STRUCT)
If *astar
With *astar
\start\x = X1
\start\y = Y1
\stop\x = X2
\stop\y = Y2
\mask\width = Width
\mask\height = Height
\mask\size = \mask\width * \mask\height
\mask\buffer = AllocateMemory(\mask\size)
If \mask\buffer
CopyMemory(*Buffer,\mask\buffer,\mask\size)
If AddElement(\node())
\node()\offset\x = \stop\x
\node()\offset\y = \stop\y
astar_Parent(*astar,@\node())
If \path
ProcedureReturn *astar
EndIf
EndIf
FreeMemory(\mask\buffer)
EndIf
EndWith
FreeStructure(*astar)
EndIf
EndIf
EndIf
EndIf
EndProcedure
Procedure.i astar_Path(*astar.ASTAR_STRUCT,*Vector.ASTAR_OFFSET_STRUCT)
With *astar
If \path
*Vector\x = \path\offset\x
*Vector\y = \path\offset\y
\path = \path\parent
ProcedureReturn #True
EndIf
EndWith
EndProcedure
Procedure.i astar_TaskFree(*astar.ASTAR_STRUCT)
With *astar
FreeMemory(\mask\buffer)
FreeStructure(*astar)
EndWith
EndProcedure
*dummy = astar_Task(0,0,15,15,?mask,16,16)
If *dummy
Debug "PATH FOUND!"
While astar_Path(*dummy,@position)
Debug Str(position\x) + " x " + Str(position\y)
Wend
astar_TaskFree(*dummy)
Else
Debug "NO PATH FOUND!"
EndIf
DataSection
mask:
!db 0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
!db 0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
!db 0,0,0,0,1,1,0,0,0,0,0,0,0,0,0,0
!db 0,0,1,1,1,1,0,0,0,0,0,0,0,0,0,0
!db 0,0,0,0,1,1,0,0,0,0,0,0,0,0,0,0
!db 0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
!db 0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
!db 0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
!db 0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
!db 0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
!db 0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
!db 0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
!db 0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
!db 0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
!db 0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0
!db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0;<- die zeile mit dieser ersetzen: 0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0 und die Suche schlägt fehl!
!db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
EndDataSection