Isometrische 2D Spiele-Engine

Spiele, Demos, Grafikzeug und anderes unterhaltendes.
Benutzeravatar
Mijikai
Beiträge: 754
Registriert: 25.09.2016 01:42

Re: Isometrische 2D Spiele-Engine

Beitrag von Mijikai »

diceman 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.
Ist noch ein Thema :)

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
Benutzeravatar
diceman
Beiträge: 347
Registriert: 06.07.2017 12:24
Kontaktdaten:

Re: Isometrische 2D Spiele-Engine

Beitrag von diceman »

Ach du Scheiße. :o
Ich habs ganz vergessen. Habe lange nicht mehr hier reingeschaut, stattdessen habe viel gelesen, Filme geguckt und Heroes of the Storm gezockt. Jetzt letztes Wochenende war ich auf einem kleinen lokalen GameJam, da habe ich etwas mit PureBasic gebastelt, und das Thema ist wieder relevant geworden.
Brauchst du die A*-Routine noch?
Now these points of data make a beautiful line,
And we're out of Beta, we're releasing on time.
Benutzeravatar
Mijikai
Beiträge: 754
Registriert: 25.09.2016 01:42

Re: Isometrische 2D Spiele-Engine

Beitrag von Mijikai »

Ja, würde mir helfen :)
Programmiere gerade wieder für die 2D Engine.
Das nächste Update wird Isometrie-Funktionen enthalten.
Benutzeravatar
Mijikai
Beiträge: 754
Registriert: 25.09.2016 01:42

Re: Isometrische 2D Spiele-Engine

Beitrag von Mijikai »

Hab mich heute nochmal an den A* Algorithmus gewagt
und habs hinbekommen :D

Bild
Benutzeravatar
diceman
Beiträge: 347
Registriert: 06.07.2017 12:24
Kontaktdaten:

Re: Isometrische 2D Spiele-Engine

Beitrag von diceman »

Gratulation. :)
Freut mich, daß du eine für dich funktionierende Lösung gefunden hast. Ich war das ganze Wochenende auf einer beruflichen Fortbildung, daher habe ich hier noch gar nicht reingeschaut, also nochmal sorry fürs nicht zeitnah eingehaltene Versprechen. /:->
Now these points of data make a beautiful line,
And we're out of Beta, we're releasing on time.
Benutzeravatar
Mijikai
Beiträge: 754
Registriert: 25.09.2016 01:42

Re: Isometrische 2D Spiele-Engine

Beitrag von Mijikai »

diceman hat geschrieben:Gratulation. :)
Freut mich, daß du eine für dich funktionierende Lösung gefunden hast.
Danke :)

Es fehlt allerdings noch eine Version ohne diagonale Felder.
Eventuell hast du mir einen Tipp dafür.

Hab bisher nur mal versucht die diagonalen Felder zu ignorieren wenn ich
die Nachbarn untersuche.
Benutzeravatar
diceman
Beiträge: 347
Registriert: 06.07.2017 12:24
Kontaktdaten:

Re: Isometrische 2D Spiele-Engine

Beitrag von diceman »

Ich habe das folgendermaßen gelöst …
Habe am Anfang des Programms die x/y-Modifikatoren für alle 4 Himmelsrichtungen als Array eingelesen, also:

Code: Alles auswählen

Enumeration
    #nord
    #west
    #east
    #south
EndEnumeration

xMod(0) = 0
yMod(0) = -1
xMod(1) = -1
yMod(1) = 0
xMod(2) = 1
yMod(2) = 0
xMod(3) = 0
yMod(3) = 1
Und so ist es ein leichtes mit

Code: Alles auswählen

For dir = 0 to 3
    If map(x+xMod(dir),y+yMod(dir)) = #isNotWall
        …
    Endif
Next
ausschließlich durch alle 4 Himmelsrichtungen zu rotieren.
Abgesehen davon kann man die Modifikatoren auch noch für viele andere tolle Sachen nutzen, zum Beispiel Tastaturabfrage und Bewegung der Spielfigur, geführte prozedurale Generierung, etc. :)
Now these points of data make a beautiful line,
And we're out of Beta, we're releasing on time.
Benutzeravatar
Mijikai
Beiträge: 754
Registriert: 25.09.2016 01:42

Re: Isometrische 2D Spiele-Engine

Beitrag von Mijikai »

diceman hat geschrieben:Ich habe das folgendermaßen gelöst …
Das mit der Enumeration gefällt mir :)

Also sollte es doch gehen wenn die Diagonalen nicht berücksichtigt werden.
Hab es mir also nochmal angeschaut und das Problem gefunden -
hatte vergessen das ich was auskommentiert hatte :oops:

Test:
Bild

Allerdings wird der kürzeste Pfad (dunkelgrün) ohne Hindernisse jetzt so generiert (Bild unten) was mir nicht so gefällt :freak:
Der hellgrüne Pfad wäre schöner allerdings läuft hier der Spieler dann auch zick zack was u.U. auch schlecht aussieht.... was tun? ist das so ok?

Bild

Wie sieht bei dir der kürzeste Pfad aus wenn die Diagonalen nicht berücksichtigt werden?
Benutzeravatar
diceman
Beiträge: 347
Registriert: 06.07.2017 12:24
Kontaktdaten:

Re: Isometrische 2D Spiele-Engine

Beitrag von diceman »

Ich habe dir hier mal meinen kompletten A*-Testcode rüberkopiert, das Programm ist vollkommen eigenständig lauffähig.
Es wird eine zufällige "Welt" aus zufälligen Blöcken erstellt, sowie ein zufälliger Start- und Zielpunkt gesetzt.
Mit der linken Maustaste kannst du den Startpunkt versetzen, und der Pfad wird daraufhin aktualisiert. Durch Drücken der Return-Taste erstellst du eine neue Welt.
Die ganze A*-Magie findet in der Prozedur getPath() statt. Dort findest du auch (in Zeile 279) das Macro _NoCornerCuts() ... sobald du dieses auskommentierst, "schneidet" die Pfadsuche Ecken von Blöcken ab, was nicht so schön smooth aussieht (alles eine Frage, ob du erlauben möchtest, daß der Spieler an diagonal angrenzenden Blöcken "vorbeischlüpfen" darf).
Diese Version der Pfadsuche bezieht auch die diagonalen Felder ein.
Wenn du ausschließlich orthogonale Pfadsuche haben möchtest, mußt du Zeile 273 wie folgt ändern:

Code: Alles auswählen

If (x = *nodePointer\X And y = *nodePointer\Y) Or binaryMap(x,y) = 0 Or checkList(x,y) = -1 Or (x <> *nodePointer\x And y <> *nodePointer\y)
Meinen A*-Code habe ich im Laufe von bestimmt 8 Jahren immer weiter auf maximale Effizienz und Geschwindigkeit optimiert (angefangen hat das in BlitzBasic), deswegen erlaube ich mir auch ein einziges Goto in der getPath()-Prozedur, um die Pfadsuche umgehend zu verlassen, sobald ein eindeutiges Ergebnis vorliegt.
Der Pfad wird aufgezeichnet, in einer Liste gespeichert, und kann so anschließend abgerufen werden.
Der getPath()-Code ist kommentiert, aber wenn du irgendwelche Fragen hast, stehe ich dir natürlich gerne Rede und Antwort. :)

Code: Alles auswählen

EnableExplicit

Macro _NoCornerCuts()
	If x <> *nodePointer\X And y <> *nodePointer\Y
		If x < *nodePointer\X And y < *nodePointer\Y	;NW
			If binaryMap(limit(*nodePointer\X-1,0,xMax),*nodePointer\Y) = 0 Or binaryMap(*nodePointer\X,limit(*nodePointer\Y-1,0,yMax)) = 0
				tileOkay = 0
			EndIf
		EndIf
		If x > *nodePointer\X And y < *nodePointer\Y	;NE
			If binaryMap(limit(*nodePointer\X+1,0,xMax),*nodePointer\Y) = 0 Or binaryMap(*nodePointer\X,limit(*nodePointer\Y-1,0,yMax)) = 0
				tileOkay = 0
			EndIf
		EndIf
		If x < *nodePointer\X And y > *nodePointer\Y	;SW
			If binaryMap(limit(*nodePointer\X-1,0,xMax),*nodePointer\Y) = 0 Or binaryMap(*nodePointer\X,limit(*nodePointer\Y+1,0,yMax)) = 0
				tileOkay = 0
			EndIf
		EndIf
		If x > *nodePointer\X And y > *nodePointer\Y	;SO
			If binaryMap(limit(*nodePointer\X+1,0,xMax),*nodePointer\Y) = 0 Or binaryMap(*nodePointer\X,limit(*nodePointer\Y+1,0,yMax)) = 0
				tileOkay = 0
			EndIf
		EndIf
	EndIf
EndMacro


Declare createWindow(x,y,exeName.s)
Declare createWorld(xMax,yMax)
Declare showWorld(xMax,yMax)
Declare getPath(x0,y0,xTarget,yTarget,xMax,yMax)
Declare limit(var,min,max)

Global Dim binaryMap(1,1)


Structure NODE
	X.i
	Y.i
EndStructure

Structure A_STAR_PATH ;Zum Aufzeichnen des Pfades
	X.i
	Y.i
EndStructure
Global NewList aStarPath.A_STAR_PATH()



Global screen
Define quit

#xRes = 800
#yRes = 600

#tileSize = 20
#xMax = 39
#yMax = 29

Global startX, startY
Global exitX, exitY
Global pathExist
screen = createWindow(#xRes,#yRes,"A-Star.exe")

Repeat
	createWorld(#xMax,#yMax)
	ClearList(aStarPath())
	pathExist = getPath(startX,startY,exitX,exitY,#xMax,#yMax)
	quit = showWorld(#xMax,#yMax)
Until quit



Procedure createWindow(x,y,exeName.s)
	Define window

    If Not InitSprite() : Debug "InitSprite() failed" : End : EndIf
   
   	window = OpenWindow(#PB_Any,0,0,x,y,exeName,#PB_Window_ScreenCentered)
    If Not window : Debug "Window-Creation failed" : End : EndIf
    If Not OpenWindowedScreen(WindowID(window),0,0,x,y) : Debug "Screen-Creation failed" : End : EndIf
    
    If Not InitMouse() : Debug "InitMouse() failed" : End : EndIf
    If Not InitKeyboard() : Debug "InitKeyboard() failed" : End : EndIf
     
    ProcedureReturn window
EndProcedure



Procedure showWorld(xMax,yMax)
	Define x,y
	Define rad
	Define event, keyboardReturn, quit
	Define *parentPointer.A_STAR_PATH = #Null
	Define drawBoard = CreateImage(#PB_Any,#xRes,#yRes)
	
	Define wallImage = CreateImage(#PB_Any,#tileSize,#tileSize)
	If StartDrawing(ImageOutput(wallImage))
		DrawingMode(#PB_2DDrawing_Default)
		Box(0,0,#tileSize,#tileSize,RGB(0,0,0))
		StopDrawing()
	EndIf
	

draw_stuff:	
	If StartDrawing(ImageOutput(drawBoard))
		DrawingMode(#PB_2DDrawing_Default)
		Box(0,0,#xRes,#yRes,RGB(255,255,255))
		For x = 0 To xMax
			For y = 0 To yMax
				If binaryMap(x,y) = 0
					DrawImage(ImageID(wallImage),x*#tileSize,y*#tileSize)
				EndIf
			Next
		Next
		
		
		Circle((startX*#tileSize)+(#tileSize/2),(startY*#tileSize)+(#tileSize/2),#tileSize/2,RGB(0,100,255))
		Circle((exitX*#tileSize)+(#tileSize/2),(exitY*#tileSize)+(#tileSize/2),#tileSize/2,RGB(225,0,0))
		
		ResetList(aStarPath())
		If FirstElement(aStarPath())
			*parentPointer = @aStarPath()
			ForEach aStarPath()
				LineXY((*parentPointer\X*#tileSize)+(#tileSize/2),(*parentPointer\Y*#tileSize)+(#tileSize/2),(aStarPath()\X*#tileSize)+(#tileSize/2),(aStarPath()\Y*#tileSize)+(#tileSize/2),RGB(0,100,255))
				*parentPointer = @aStarPath()
			Next
		EndIf
		StopDrawing()
	EndIf
		
	Repeat
		ExamineKeyboard()
		ExamineMouse()
		
		ClearScreen(RGB(255,255,255))
		If StartDrawing(ScreenOutput())
			DrawImage(ImageID(drawBoard),0,0)
			DrawingMode(#PB_2DDrawing_Outlined)
			Circle(MouseX(),MouseY(),#tileSize/2-3,RGB(0,150,0))
			Circle(MouseX(),MouseY(),#tileSize/2-6,RGB(0,150,0))
			
			StopDrawing()
		EndIf
		FlipBuffers()
			
		If MouseButton(#PB_MouseButton_Left)
			For x = 0 To xMax
				For y = 0 To yMax
					If MouseX() >= x*#tileSize And MouseX() < (x*#tileSize)+#tileSize And MouseY() >= (y*#tileSize) And MouseY() < (y*#tileSize)+#tileSize
						If binaryMap(x,y) = 1 And (Not (x = exitX And y = exitY))
							startX = x
							startY = y
							ClearList(aStarPath())
							pathExist = getPath(startX,startY,exitX,exitY,#xMax,#yMax)
							Goto draw_stuff
						EndIf
					EndIf
				Next
			Next
		EndIf
		
		
		event = WaitWindowEvent(1)
		Delay(1)

		
		keyboardReturn = KeyboardReleased(#PB_Key_Return)
		If KeyboardPushed(#PB_Key_Escape) Or event = #PB_Event_CloseWindow
			ProcedureReturn 1
		EndIf
	Until keyboardReturn
EndProcedure



Procedure createWorld(xMax,yMax)
	Define x,y
	
	Dim binaryMap(xMax,yMax)
	For x = 0 To xMax
		For y = 0 To yMax
			binaryMap(x,y) = limit(Random(2,0),0,1)
		Next
	Next
	
	Repeat
		startX = Random(xMax,0)
		startY = Random(yMax,0)
		exitX = Random(xMax,0)
		exitY = Random(yMax,0)
	Until binaryMap(startX,startY) = 1 And binaryMap(exitX,exitY) = 1 And (startX <> exitX Or startY <> exitY)
EndProcedure



Procedure limit(var,min,max)
	If var < min
		ProcedureReturn min
	Else
		If var > max
			ProcedureReturn max
		Else
			ProcedureReturn var
		EndIf
	EndIf
EndProcedure




Procedure getPath(x0,y0,xTarget,yTarget,xMax,yMax) ;xM/yM = maximale Feldgröße
	#costStraight = 10
	#costDiagonal = 14		;Quadratwurzel 2
	
	NewList node.NODE()
	
	Dim checkList(xMax,yMax)	;Schnelles Schreiben in die Open-List (= 1) und die Closed-List (-1)
	Dim g_cost(xMax,yMax)	;G-Kosten = bekannte Pfadkosten-Summe zum aktuellen Tile
	Dim h_cost(xMax,yMax)	;H-Kosten = Geschätzte verbleibende Entfernung vom bekannten Tile aus (Luftlinie)
	Dim f_cost(xMax,yMax)	;F-Kosten = G + H
	
	Dim parentX(xMax,yMax)	;Parent-Nodes speichern ...
	Dim parentY(xMax,yMax)	;... damit gefundener Pfad abgerufen werden kann

	Define firstNode
	Define lowF
	Define nodeCost
	Define x, y
	Define tileOkay
	Define *nodePointer.NODE ;Pointer auf Speicheradresse der aktuellen Node

	Define count	;Zählt Schritte von Start zum Ziel (0 = kein Pfad existiert, -1 = Start und Zielort identisch)
	
	If x0 = xTarget And y0 = yTarget
		ProcedureReturn -1 ;Start und Zielfeld sind dasselbe
	Else
		;Add first Node to Open List
		checkList(xTarget,yTarget) = 1
		AddElement(node())
		node()\X = xTarget					;Pfad wird rückwärts gesucht ...
		node()\Y = yTarget					;... Aufzeichnen erfolgt am Ende mittels Rückverfolgung der Parent-Nodes
		;erstes Element hat keinen Parent
		
		;optionale G-Penalities für bestimmte Felder festlegen
		;Beispiel: g_cost(lavaX,lavaY) = 1000
		Repeat
			;find Low F
			firstNode = FirstElement(node())
			If firstNode = #Null
				ProcedureReturn 0
				;optionale Konsequenz aufrufen, wenn kein Pfad gefunden wurde
			Else
				lowF = f_cost(node()\X,node()\Y)
				*nodePointer = @node()
				ForEach node()
					If f_cost(node()\X,node()\Y) < lowF				
						lowF = f_cost(node()\X,node()\Y)
						*nodePointer = @node()
					EndIf
				Next
			EndIf
			
			;Angrenzende Felder überprüfen
			If checkList(*nodePointer\X,*nodePointer\Y) = 1
				checkList(*nodePointer\X,*nodePointer\Y) = -1
				
				For x = limit(*nodePointer\X-1, 0, xMax) To limit(*nodePointer\X+1, 0, xMax)
					For y = limit(*nodePointer\Y-1, 0, yMax) To limit(*nodePointer\Y+1, 0, yMax)	
						
						If (x = *nodePointer\X And y = *nodePointer\Y) Or binaryMap(x,y) = 0 Or checkList(x,y) = -1
							Continue ;Parent-Nodes, blockierte- und ClosedList-Tiles direkt überspringen = Speed!
						EndIf
						
						tileOkay = 1
						;optional: keine Ecken "abschneiden":
						_NoCornerCuts()	;Macro
						
						If tileOkay
							If x = x0 And y = y0 ;Wenn Ziel erreicht wurde ...
								parentX(x,y) = *nodePointer\X
								parentY(x,y) = *nodePointer\Y
								Goto pathFound	;... Routine verlassen und Pfad aufzeichnen
							EndIf
							If checkList(x,y) = 1
								;checken, ob der Weg zum bereits bekannten Feld über den neuen Pfad kürzer ist.
								;Wenn ja, dann Parent-Koordinaten des bekannten Feldes "umleiten".
								nodeCost = #costStraight
								If (x <> *nodePointer\X And y <> *nodePointer\Y)
									nodeCost = #costDiagonal
								EndIf
								If (g_cost(*nodePointer\X,*nodePointer\Y) + nodeCost) < g_cost(x,y)
									g_cost(x,y) = g_cost(*nodePointer\X,*nodePointer\Y) + nodeCost
									f_cost(x,y) = g_cost(x,y) + h_cost(x,y)
									parentX(x,y) = *nodePointer\X
									parentY(x,y) = *nodePointer\Y
								EndIf
							EndIf
							If checkList(x,y) = 0
								;Add to Open List
								checkList(x,y) = 1
								AddElement(node())
								node()\X = x
								node()\Y = y
								parentX(x,y) = *nodePointer\X
								parentY(x,y) = *nodePointer\Y
								nodeCost = #costStraight
								If x <> *nodePointer\X And y <> *nodePointer\Y
									nodeCost = #costDiagonal
								EndIf
								g_cost(x,y) + g_cost(*nodePointer\X,*nodePointer\Y) + nodeCost
								h_cost(x,y) = (Abs(x-x0) + Abs(y-y0)) * #costStraight			;Annäherung statt Satz des Pythagoras = ausreichend, da nur Längenvergleich stattfindet
								f_cost(x,y) = g_cost(x,y) + h_cost(x,y)
							EndIf
						EndIf
							

					Next
				Next

				ChangeCurrentElement(node(), *nodePointer)	;auf aktuelles Listenelement zurückschalten damit richtiges Element
				DeleteElement(node())						;gelöscht wird (falls in der Zwischenzeit AddElement() aufgerufen wurde)

			EndIf
			
		ForEver			
	EndIf
	
	
	
	
pathFound:		;Pfad aufzeichnen und ...
	count = 1
	AddElement(aStarPath())
	aStarPath()\X = x0
	aStarPath()\Y = y0
	*nodePointer = @aStarPath()
	
	Repeat
		count +1
		AddElement(aStarPath())
		aStarPath()\X = parentX(*nodePointer\X,*nodePointer\Y)
		aStarPath()\Y = parentY(*nodePointer\X,*nodePointer\Y)
		*nodePointer = @aStarPath()
	Until aStarPath()\X = xTarget And aStarPath()\Y = yTarget
	
	ProcedureReturn count ;... Schrittanzahl an Requester zurückgeben
EndProcedure
Zuletzt geändert von diceman am 22.05.2019 11:37, insgesamt 1-mal geändert.
Now these points of data make a beautiful line,
And we're out of Beta, we're releasing on time.
Benutzeravatar
Mijikai
Beiträge: 754
Registriert: 25.09.2016 01:42

Re: Isometrische 2D Spiele-Engine

Beitrag von Mijikai »

diceman hat geschrieben:Ich habe dir hier mal meinen kompletten A*-Testcode rüberkopiert, das Programm ist vollkommen eigenständig lauffähig.
Es wird eine zufällige "Welt" aus zufälligen Blöcken erstellt, sowie ein zufälliger Start- und Zielpunkt gesetzt.
Mit der linken Maustaste kannst du den Startpunkt versetzen, und der Pfad wird daraufhin aktualisiert. Durch Drücken der Return-Taste erstellst du eine neue Welt.
Die ganze A*-Magie findet in der Prozedur getPath() statt. Dort findest du auch (in Zeile 279) das Macro _NoCornerCuts() ... sobald du dieses auskommentierst, "schneidet" die Pfadsuche Ecken von Blöcken ab, was nicht so schön smooth aussieht (alles eine Frage, ob du erlauben möchtest, daß der Spieler zwischen zwei diagonalen Blöcken durchschlüpfen darf).
Diese Version der Pfadsuche bezieht auch die diagonalen Felder ein.
Wenn du ausschließlich orthogonale Pfadsuche haben möchtest, mußt du Zeile 273 wie folgt ändern:

Code: Alles auswählen

If (x = *nodePointer\X And y = *nodePointer\Y) Or binaryMap(x,y) = 0 Or checkList(x,y) = -1 Or (x <> *nodePointer\x And y <> *nodePointer\y)
Meinen A*-Code habe ich im Laufe von bestimmt 8 Jahren immer weiter auf maximale Effizienz und Geschwindigkeit optimiert (angefangen hat das in BlitzBasic), deswegen erlaube ich mir auch ein einziges Goto in der getPath()-Prozedur, um die Pfadsuche umgehend zu verlassen, sobald ein eindeutiges Ergebnis vorliegt.
Der Pfad wird aufgezeichnet, in einer Liste gespeichert, und kann so anschließend abgerufen werden.
Der getPath()-Code ist kommentiert, aber wenn du irgendwelche Fragen hast, stehe ich dir natürlich gerne Rede und Antwort. :)
...
Danke für das Code Beispiel :)

_NoCornerCuts() :o - einfach genial!

Mal sehen ob ich das auch so umsetzen kann.
Ich vermute das der Aufruf des Macros nach dem Check der Closed List stattfindet?
Das Macro checkt die Felder um das momentane Feld und entscheidet ob es berücksichtigt wird?

Ich gönn mir jetzt eine Tasse Tee und studier den Code :D
Antworten