A*Algo Pfadfinding. Aufbereitet.

Übersicht BlitzBasic Codearchiv

Neue Antwort erstellen

 

Matthias

Betreff: A*Algo Pfadfinding. Aufbereitet.

 BeitragDo, Jun 07, 2007 15:05
Antworten mit Zitat
Benutzer-Profile anzeigen
Hay.
Da der Algo doch so schwer zu verstehne ist habe ich
mir die Arbeit gemacht den Standart A*Algo so umzubauen das er besser zu verstehen ist und dadurch besser einsetzbar ist. Zusäzlich habe ich ein kleines Symbol gemacht das dann den gesuchten Pfad entlang fährt und sich enstprechend ausrichtet.
Der einfache A*Algo ist zwar recht simpel zu verstehen hat aber leider den bösen nachteil das er sehr langsam ist.
Demzofoge kann mann ihn wirklich nur für eine MapGröße (Dim Map(100,100)) benuzen. Alles was darüber hinausgeht dauert bei ca 1.8GHz mehr als 40ms und die 25Bilder pro Sekunde sind nicht mehr gewärleistet.
=Programm Hackt.
Noch 2Tipps.
Erst prüfen ob es einen direkten weg zum Ziel gibt.
Dann erst mit einen simplen Füllalgo Checken ob das Ziel
überhaupt ereichbar ist.

Mit den Tasten 1,2 und 3 Kann mann dann die verschiedenen
Pfadfinding Algos Testen.
Viel Spaß beim Testen.
Mfg Matthias


Code: [AUSKLAPPEN]

Graphics 800,600,32,2
Global MapUntg=CreateImage(800,600)
Global PfadBank=CreateBank(2)
Global mapwidth,mapheight;"Wichtig für Pfadfinding"

Dim MapData$(50),Fighter(72)
Dim Map(50,50)


;"----------Pfadfinding Vorbereitung----------------"
Dim sqrmap(50,50),nodemap(0,0),dirx(7),diry(7),dirz(7)
For i=0 To 7:Read dirx(i):Read diry(i):Read dirz(i):Next
Type node
Field parent.node,cost,x,y
End Type

Type open
Field node.node
End Type

Type path
Field node.node
End Type
Data 0,-1,0,  -1,0,0,  1,0,0,  0,1,0
Data -1,-1,1,  1,-1,1,  -1,1,1,  1,1,1
;---------------Vorbereitung beendet----------------


MapData$(00)="11111111111111111111111111111111"
MapData$(01)="10000000000000000000000000000001"
MapData$(02)="10011111111111111111111111111101"
MapData$(03)="10000000000100000000000000000001"
MapData$(04)="10000000000100000000000000000001"
MapData$(05)="10000000000100000000000000000001"
MapData$(06)="10000000000100000000000000000001"
MapData$(07)="10000000000111011111111111111111"
MapData$(08)="10000000000100000000000000000001"
MapData$(09)="10000000000100000000000000000001"
MapData$(10)="10000000000100000000000000000001"
MapData$(11)="10000000000100000000000000000001"
MapData$(12)="10000000000100000000000000000001"
MapData$(13)="10000000000100000000000000000001"
MapData$(14)="10000000000100000000000000000001"
MapData$(15)="10000000000100000000000000000001"
MapData$(16)="10000000000100000000000000000001"
MapData$(17)="10000000000100000000000000000001"
MapData$(18)="10000000000100000000000000000001"
MapData$(19)="10000000000100000000000000000001"
MapData$(20)="10000000000100000000000000000001"
MapData$(21)="10000000000100000000000000000001"
MapData$(22)="10000000000100000000000000000001"
MapData$(23)="11111111111111111111111111111111"



ClsColor 180,180,180
CreateFighter()
LoadMap()
ZeigeMap()

StartX=5:StartY=20
EndeX=30:EndeY=10
SetBuffer BackBuffer()



;=========MainLoop=========================================
Repeat:
DrawBlock MapUntg,0,0
;---------Start/End Position--"
If MouseDown(1)=1 Then StartX=MouseX()/25:StartY=MouseY()/25
If MouseDown(2)=1 Then EndeX=MouseX()/25:EndeY=MouseY()/25
Color 255,255,0:Text StartX*25+12,StartY*25+12,"S",1,1
Color 255,0,0:Text EndeX*25+12,EndeY*25+12,"E",1,1



;"Tastertur 1,2,3 für die PfadfindingAlgos
If KeyHit(2):pathfinding0(startx,starty,endex,endey)
    FightStep=PfadSpliner():AppTitle "Typ1":End If

If KeyHit(3):pathfinding1(startx,starty,endex,endey)
    FightStep=PfadSpliner():AppTitle "Typ2":End If

If KeyHit(4):pathfinding2(startx,starty,endex,endey)
    FightStep=PfadSpliner():AppTitle "Typ3":End If

;------Zeigt den Pfad an
M=BankSize(PfadBank)-8:LockBuffer:For I=0 To M Step 4:
WritePixelFast PeekShort(PfadBank,I),PeekShort(PfadBank,I+2),-1
Next:UnlockBuffer

;------Fighter wird bewegt wenn Ziel nicht erreicht ist 0=Ziel
If FightStep>0 Then FightStep=Bewegung(FightStep)

Flip:Until KeyDown(1)=1:End
;"============================================================











Function Bewegung(FightStep):M=BankSize(PfadBank)
;"X,Y Koords aus der Bank Lesen
;"Winkel aus den über über über nästen Koords berechnen"

X=PeekShort(PfadBank,FightStep)
Y=PeekShort(PfadBank,FightStep+2)
XNext=PeekShort(PfadBank,FightStep-12)
YNext=PeekShort(PfadBank,FightStep-10)
Wink=Int(ATan2(XNext-X,Y-YNext)/5)
If Wink<0 Then Wink=72+Wink
Wink=Wink Mod 72
DrawImage Fighter(Wink),X,Y
Return FightStep-4

End Function


Function PfadSpliner()
;"Pfad Abrunden(Spliner) und in die PfadBank transverieren
;damit mann auf die über über über nästen Daten zugreifen kann
FreeBank(PfadBank):PfadBank=CreateBank(4)
For path.path=Each path
      If path=Last path Then Exit
      tmp.path=Before path
      If tmp=Null Then
        x0=path\node\x
        y0=path\node\y
      Else
        x0=tmp\node\x
        y0=tmp\node\y
      EndIf
      x1=path\node\x
      y1=path\node\y
      tmp.path=After path
      x2=tmp\node\x
      y2=tmp\node\y
      tmp.path=After tmp
      If tmp=Null Then
        x3=x2
        y3=y2
      Else
        x3=tmp\node\x
        y3=tmp\node\y
      EndIf

    spline(X0,Y0,X1,Y1,X2,Y2,X3,Y3)
    Next
Return BankSize(PfadBank)-4
End Function


Function spline(x1,y1,x2,y2,x3,y3,x4,y4)
;"Standart spliner Algo"
Ras=25:Rh=Ras/2
x1=x1*Ras+rh:y1=y1*Ras+rh
x2=x2*Ras+rh:y2=y2*Ras+rh
x3=x3*Ras+rh:y3=y3*Ras+rh
x4=x4*Ras+rh:y4=y4*Ras+rh
  For u#=0 To 1.1 Step .1
    u2#=u#*u#
    u3#=u#*u#*u#
    f1#=-0.5*u3#+1.0*u2#-0.5*u#
    f2#= 1.5*u3#-2.5*u2#+1.0
    f3#=-1.5*u3#+2.0*u2#+0.5*u#
    f4#= 0.5*u3#-0.5*u2#
    x=x1*f1#+x2*f2#+x3*f3#+x4*f4#
    y=y1*f1#+y2*f2#+y3*f3#+y4*f4#

If ax<>x Or ay<>y Then
Pos=BankSize(PfadBank):ResizeBank(PfadBank,Pos+4)
PokeShort(PfadBank,Pos,x)
PokeShort(PfadBank,Pos+2,y)

End If
ax=X:ay=Y
      Next
End Function



Function ZeigeMap()
;Hindernisse zeigen
SetBuffer ImageBuffer(MapUntg):Cls
Color 0,0,200
For ZX=0 To 49:For ZY=0 To 49
If Map(ZX,ZY)>0 Then Rect ZX*25,ZY*25,24,24
Next:Next
SetBuffer BackBuffer()
End Function

Function CreateFighter()
;"Fighter herstellen und in 72 Winkel drehen (360/5)
:Fighter(0)=CreateImage(15,21)
SetBuffer ImageBuffer(Fighter(0)):MidHandle Fighter(0):Color 0,0,200
For I=0 To 7:Line 7,0,I,11:Line 8,0,14-I,11:Next:Rect 0,12,15,10:Color 255,255,0
Rect 2,17,11,5:For I=1 To 72:Fighter(I)=CopyImage(Fighter(0))
RotateImage Fighter(I),I*5:Next
End Function



Function LoadMap():MaxX=Len(MapData$(00))-1
;MapDatas Lesen"
Repeat:For X=0 To MaxX:Map(X,Y)=Asc(Mid(MapData$(Y),X+1,1))-48
Next:Y=Y+1:Until Len(MapData$(Y))<1:
mapwidth=MaxX-1:mapheight=Y-1
End Function









Function pathfinding0(startx,starty,endx,endy)
  Delete Each node
  Delete Each open
  Delete Each path
  Dim nodemap(mapwidth,mapheight)
  If startx=endx And starty=endy Then Return

  node.node=New node
  node\x=startx
  node\y=starty
  open.open=New open
  open\node=node
  nodemap(startx,starty)=1

  .again0
  node=Null
  cost=2147483647
  For open=Each open
    delta=Abs(open\node\x-endx)+Abs(open\node\y-endy)
    If open\node\cost+delta<cost Then
      cost=open\node\cost+delta
      node=open\node
      tempopen.open=open
    EndIf
  Next
  If node=Null Then Return
  Delete tempopen

  For i=0 To 3
    x=node\x+dirx(i)
    y=node\y+diry(i)
    If x=>0 And y=>0 And x<=mapwidth And y<=mapheight Then
      If map(x,y)=0 And nodemap(x,y)=0 Then
        tempnode.node=New node
        tempnode\parent=node
        tempnode\cost=node\cost+1
        tempnode\x=x
        tempnode\y=y
        open.open=New open
        open\node=tempnode
        nodemap(x,y)=1
        If x=endx And y=endy Then finish=1:Exit
      EndIf
    EndIf
  Next
  If finish=0 Then Goto again0

  While tempnode\parent<>Null
    path.path=New path
    path\node=tempnode
    tempnode=tempnode\parent
  Wend
  path.path=New path
  path\node=tempnode
End Function





;---------------------------------------------------------------------
;A*Pathfinding 8
;---------------------------------------------------------------------
Function pathfinding1(startx,starty,endx,endy)
  Delete Each node
  Delete Each open
  Delete Each path
  Dim nodemap(mapwidth,mapheight)
  If startx=endx And starty=endy Then Return

  node.node=New node
  node\x=startx
  node\y=starty
  open.open=New open
  open\node=node
  nodemap(startx,starty)=1

  .again1
  node=Null
  cost=2147483647
  For open=Each open
    delta=Abs(open\node\x-endx)+Abs(open\node\y-endy)
    If open\node\cost+delta<cost Then
      cost=open\node\cost+delta
      node=open\node
      tempopen.open=open
    EndIf
  Next
  If node=Null Then Return
  Delete tempopen

  For i=0 To 7
    x=node\x+dirx(i)
    y=node\y+diry(i)
    If x=>0 And y=>0 And x<=mapwidth And y<=mapheight Then
      If map(x,y)=0 And nodemap(x,y)=0 Then
        If dirz(i)=1 Then
          If map(x,node\y)=1 And map(node\x,y)=1 Then Goto jump1
        EndIf
        tempnode.node=New node
        tempnode\parent=node
        tempnode\cost=node\cost+1
        tempnode\x=x
        tempnode\y=y
        open.open=New open
        open\node=tempnode
        nodemap(x,y)=1
        If x=endx And y=endy Then finish=1:Exit
        .jump1
      EndIf
    EndIf
  Next
  If finish=0 Then Goto again1

  While tempnode\parent<>Null
    path.path=New path
    path\node=tempnode
    tempnode=tempnode\parent
  Wend
  path.path=New path
  path\node=tempnode
End Function





;---------------------------------------------------------------------
;A*Pathfinding 8+
;---------------------------------------------------------------------
Function pathfinding2(startx,starty,endx,endy)
  Delete Each node
  Delete Each open
  Delete Each path
  Dim nodemap(mapwidth,mapheight)
  If startx=endx And starty=endy Then Return

  node.node=New node
  node\x=startx
  node\y=starty
  open.open=New open
  open\node=node
  nodemap(startx,starty)=1

  .again2
  node=Null
  cost=2147483647
  For open=Each open
    delta=sqrmap(Abs(open\node\x-endx),Abs(open\node\y-endy))
    If open\node\cost+delta<cost Then
      cost=open\node\cost+delta
      node=open\node
      tempopen.open=open
    EndIf
  Next
  If node=Null Then Return
  Delete tempopen

  For i=0 To 7
    x=node\x+dirx(i)
    y=node\y+diry(i)
    If x=>0 And y=>0 And x<=mapwidth And y<=mapheight Then
      If map(x,y)=0 And nodemap(x,y)=0 Then
        If dirz(i)=1 Then
          If map(x,node\y)=1 And map(node\x,y)=1 Then Goto jump2
        EndIf
        tempnode.node=New node
        tempnode\parent=node
        tempnode\cost=node\cost+1+dirz(i)
        tempnode\x=x
        tempnode\y=y
        open.open=New open
        open\node=tempnode
        nodemap(x,y)=1
        If x=endx And y=endy Then finish=1:Exit
        .jump2
      EndIf
    EndIf
  Next
  If finish=0 Then Goto again2

  While tempnode\parent<>Null
    path.path=New path
    path\node=tempnode
    tempnode=tempnode\parent
  Wend
  path.path=New path
  path\node=tempnode
End Function
  • Zuletzt bearbeitet von Matthias am Mo, Jun 18, 2007 16:04, insgesamt 3-mal bearbeitet

skey-z

 BeitragDo, Jun 07, 2007 15:19
Antworten mit Zitat
Benutzer-Profile anzeigen
Hy, nette sache, aber ich bekomme beim 3. Algo nen "Array index out of bounds" in folgender Zeile:

Zitat:
.again2
node=Null
cost=2147483647
For open=Each open
delta=sqrmap(Abs(open\node\x-endx),Abs(open\node\y-endy))
If open\node\cost+delta<cost Then
cost=open\node\cost+delta
node=open\node
tempopen.open=open
EndIf
Next
Awards:
Coffee's Monatswettbewerb Feb. 08: 1. Platz
BAC#57: 2. Platz
Twitter
 

Matthias

 BeitragDo, Jun 07, 2007 15:22
Antworten mit Zitat
Benutzer-Profile anzeigen
Oh Tatsächlich. Das sqrmap war nicht definiert. Habe ich jezt behoben.
Danke.

d-bug

 BeitragDo, Jun 07, 2007 16:05
Antworten mit Zitat
Benutzer-Profile anzeigen
...sieht nicht gerade nach BlitzMax Code aus...

~VERSCHOBEN~
Dieser Thread passte nicht in das Forum, in dem er ursprünglich gepostet wurde.

d-bug
 

Roggi

 BeitragMo, Jun 18, 2007 16:07
Antworten mit Zitat
Benutzer-Profile anzeigen
Wirklich tolle Sache! Ist auch sehr hilfreich wie ich finde. Vorallem die 3 verschiedenen Varianten sind sehr interessant. Mir macht es Spaß und ich werde es mal gebrauchen können Wink

Danke

MfG Tom
 

Madde

Gast

BeitragSo, Sep 23, 2007 16:44
Antworten mit Zitat
Ich will jetzt keinesfalls böse Verdächtigungen ausstreuen, aber deine pathfinding funktionen ähneln denen von http://www.blitzbase.de/artikel/path_1.htm sehr stark, um genau zu sein:
Sie sind komplett identisch !

Silver_Knee

 BeitragMo, Sep 24, 2007 13:37
Antworten mit Zitat
Benutzer-Profile anzeigen
das blöde nur auf BlitzBase steht kein konkreter Code sondern nur die Beschreibung wie man es lösen soll. Man kann praktisch dies hier als das "Ergebnis" der Überlegung von BlitzBase ansehen

EDIT ich korrigiere mich: es ist dem gebenen Beispielcode sehr ähnlich.
EDIT2 Der letzte Post vor dir wurde im Juni geschrieben...
  • Zuletzt bearbeitet von Silver_Knee am Mo, Sep 24, 2007 13:44, insgesamt einmal bearbeitet

BladeRunner

Moderator

BeitragMo, Sep 24, 2007 13:44
Antworten mit Zitat
Benutzer-Profile anzeigen
Stimmt nicht, Silver_knee - unter "Quellcode" ist in der Tat ein identischer Code zu finden - das einzige was anders ist ist das Beispiel was drumrumgebaut wurde, so ich das überblicken kann.
Zu Diensten, Bürger.
Intel T2300, 2.5GB DDR 533, Mobility Radeon X1600 Win XP Home SP3
Intel T8400, 4GB DDR3, Nvidia GF9700M GTS Win 7/64
B3D BMax MaxGUI
Stolzer Gewinner des BAC#48, #52 & #92

Silver_Knee

 BeitragMo, Sep 24, 2007 14:03
Antworten mit Zitat
Benutzer-Profile anzeigen
hab mich bereits korrigiert.

StepTiger

 BeitragDi, Sep 25, 2007 23:20
Antworten mit Zitat
Benutzer-Profile anzeigen
Ist es nicht trotzdem gepushe?
Aber mal allgemein: Den Code finde ich gar nicht mal schlecht. Habe ich wohl beim ersten Mal überlesen.
Noch gestern standen wir am Abgrund, doch heute sind wir schon einen Schritt weiter.
Computer:
AMD Sempron 3000+; ATI Radeon 9800 Pro; 512 MB DDR RAM 400Mhz; Asus E7N8X-E Deluxe; Samsung 200GB HD 5.4ns acces t
Gewinner: BP Code Compo #2
Π=3.141592653589793238...<--- und das aus dem kopf Laughing
Seit der Earthlings-Diskussion überzeugter Fleisch(fr)esser.
 

Matthias

Betreff: zu wenige Strategiespiele

 BeitragDo, Sep 27, 2007 16:26
Antworten mit Zitat
Benutzer-Profile anzeigen
Hay. Freut micht das sich so viele für den Code Interessieren.
Und ja. Der Pfadfinding ist Copiert von BlitzBase. Mir ging es mehr darum die Einsatzmöglichkeiten zu zeigen. Um damit denn Usern zu unterstützen die vieleicht ein Strategiespiel oder ähnliches Programieren möchten.

Weil ich sehr gerne Strategiespiele spiele
und es leider viel zu wenige im Schowcase gibt.


Mfg Matthias

darth

 BeitragMo, Okt 01, 2007 19:32
Antworten mit Zitat
Benutzer-Profile anzeigen
Ich nutze diesen Thread um meinen eigenen Pathfinder zu posten.
Die Methode ist "einfach": vom Startpunkt (0) aus, geht man alle begehbaren Felder darum herum ab und addiert eins dazu, das macht man dann weiter (solange sie unbesetzt sind) - so kommt es dann zu einem Pfad von Nummern, den man zurückverfolgen kann über die Parents der Childs.

vllt klarer mit erklärungsbild:
user posted image

Code: [AUSKLAPPEN]
Type feldchen
 Field koo[2]
 Field no
 Field idno
 Field fatherno
 Field wayto
End Type

global max=10
Dim tmpfeld(max,max)
 for x=0 to max : for y=0 to max
  tmpfeld(x,y)=1 ;0 falls unbegehbar...
 next : next

pfadlaenge=findpath(3,3,6,4)

Function findpath(startx,starty,endx,endy)
 Delete Each feldchen : anz=0
 f.feldchen=New feldchen
 f\koo[1]=startx : f\koo[2]=starty : f\no=0
 f\idno=0 : f\fatherno=-1
 searchno=0

 .searchagain
 For f.feldchen=Each feldchen
  If f\no=searchno Then
   If f\koo[1]>0 Then
    If tmpfeld(f\koo[1]-1,f\koo[2])=1 Then
     createfeld(f\koo[1]-1,f\koo[2],f\no+1,f\idno,anz+1) : anz=anz+1
     tmpfeld(f\koo[1]-1,f\koo[2])=2
    EndIf
   EndIf
   If f\koo[1]<max Then
    If tmpfeld(f\koo[1]+1,f\koo[2])=1 Then
     createfeld(f\koo[1]+1,f\koo[2],f\no+1,f\idno,anz+1) : anz=anz+1
     tmpfeld(f\koo[1]+1,f\koo[2])=2
    EndIf
   EndIf
   If f\koo[2]>0 Then
    If tmpfeld(f\koo[1],f\koo[2]-1)=1 Then
     createfeld(f\koo[1],f\koo[2]-1,f\no+1,f\idno,anz+1) : anz=anz+1
     tmpfeld(f\koo[1],f\koo[2]-1)=2
    EndIf
   EndIf
   If f\koo[2]<max Then
    If tmpfeld(f\koo[1],f\koo[2]+1)=1 Then
     createfeld(f\koo[1],f\koo[2]+1,f\no+1,f\idno,anz+1) : anz=anz+1
     tmpfeld(f\koo[1],f\koo[2]+1)=2
    EndIf
   EndIf
  EndIf
 Next
  need=0
  For x=0 To max
  For y=0 To max
   If tmpfeld(x,y)=1 Then need=1
  Next
  Next
 If need=1 Then searchno=searchno+1 : Goto searchagain ;bissl unsauber - wollte aber keine WHILE

 For f.feldchen=Each feldchen
  If f\koo[1]=endx And f\koo[2]=endy Then
   f\wayto=1 : dist=f\no
   findparent(f\fatherno)
   exit
  EndIf
 Next
 For f.feldchen=Each feldchen
  If f\wayto=0 Then Delete f.feldchen
 Next
 Return dist
End Function

Function createfeld(x,y,n,p,i)
 f.feldchen=New feldchen
 f\koo[1]=x : f\koo[2]=y : f\no=n
 f\idno=i : f\fatherno=p
End Function

Function findparent(p)
 If p<>-1 Then
  For f.feldchen=Each feldchen
   If f\idno=p Then f\wayto=1 : p=f\fatherno : Exit
  Next
  findparent(p)
 EndIf
End Function


Um den erarbeiteten Weg dann zu verfolgen benutze man diese Methode:
Code: [AUSKLAPPEN]
While X_aktuell<>endx Or Y_aktuell<>endy
 f.feldchen=First feldchen
  f=After f
  X_aktuell=f\koo[1] : Y_aktuell=f\koo[2]
  timer=MilliSecs() : While MilliSecs()-timer<250 : Wend ;kleine Schleife zur "verlangsamung" der aktion
 f=Before f : Delete f.feldchen
Wend
Diese Signatur ist leer.
  • Zuletzt bearbeitet von darth am Mo, Okt 01, 2007 19:49, insgesamt 2-mal bearbeitet
 

FWeinb

ehemals "ich"

BeitragMo, Okt 01, 2007 19:42
Antworten mit Zitat
Benutzer-Profile anzeigen
Du hast nen Kleien Fehler im code du Definiert ein Function in einer Function da Spuckt mir der Compiler immer aus Das die Function nur im Haupt Programm definiret werden kann ^^

[Edit]
Das Programm Startet Troßdem nicht ^^
"Wenn die Menschen nur über das sprächen, was sie begreifen, dann würde es sehr still auf der Welt sein." Albert Einstein (1879-1955)
"If you live each day as if it was your last, someday you'll most certainly be right." Steve Jobs

darth

 BeitragMo, Okt 01, 2007 19:45
Antworten mit Zitat
Benutzer-Profile anzeigen
... ja -.- ich hab ein next vergessen oben. wird gleich korrigiert ...
es ist auch kein programm mensch -.- es ist ein ALGORITHMUS den man in ein programm einbauen muss...
stell mich nicht wien idioten dar und überleg mal n bisschen :O (ausserdem startet das programm, es tut nur nix...)

hmmm. ich muss im algorithmus eine kleine "schönheitskorrektur" einfügen. es gibt endlosschleifen, sollte entweder das ziel oder der start unzugänglich sein. das ist natürlich unschön (ändert aber nichts am algorithmus).

des weiteren habe ich mitlerweilen (unter protest!) die goto-schleife ersetzt und eine weitere abbruchbedingung hinzugefügt. es kann nämlich durchaus sein dass ein feld gänzlich von jedem zugang abgeriegelt ist und daher den code in eine endlose schleife jagd.

daher das update (wodurch der code enorm schwerfällig wird -.-):
Code: [AUSKLAPPEN]
Graphics 800,600

Type feldchen
 Field koo[2]
 Field no
 Field idno
 Field fatherno
 Field wayto
End Type

Global max=10
Dim tmpfeld(max,max)
 For x=0 To max : For y=0 To max
  tmpfeld(x,y)=1 ;0 falls unbegehbar...
 Next : Next
  tmpfeld(2,2)=0
  tmpfeld(2,3)=0
  tmpfeld(2,4)=0
  tmpfeld(3,4)=0
  tmpfeld(4,4)=0
  tmpfeld(4,3)=0
  tmpfeld(4,2)=0
  ;tmpfeld(3,2)=0

pfadlaenge=findpath(3,3,6,4)
 For x=0 To max : For y=0 To max
  Rect x*20,y*20,20,20,(2-tmpfeld(x,y))
 Next : Next
 For f.feldchen=Each feldchen
  Rect f\koo[1]*20+2,f\koo[2]*20+2,16,16,0
  Text f\koo[1]*20,f\koo[2]*20,f\no
 Next
 Flip 0

 X_aktuell=3 : Y_aktuell=3
 endx=6 : endy=4
 If pfadlaenge<>0 Then
  While X_aktuell<>endx Or Y_aktuell<>endy
   f.feldchen=First feldchen
    f=After f
    X_aktuell=f\koo[1] : Y_aktuell=f\koo[2]
    timer=MilliSecs() : While MilliSecs()-timer<250 : Wend ;kleine Schleife zur "verlangsamung" der aktion
   f=Before f : Delete f.feldchen
   Rect X_aktuell*20+5,Y_aktuell*20+5,10,10,0
  Wend
 EndIf
WaitKey() : End

Function findpath(startx,starty,endx,endy)
  break=0
  If startx>0 Then
   If tmpfeld(startx-1,starty)=0 Then break=break+1
  Else : break=break+1 : EndIf
  If startx<max Then
   If tmpfeld(startx+1,starty)=0 Then break=break+1
  Else break=break+1 : EndIf
  If starty>0 Then
   If tmpfeld(startx,starty-1)=0 Then break=break+1
  Else : break=break+1 : EndIf
  If starty<max Then
   If tmpfeld(startx,starty+1)=0 Then break=break+1
  Else : break=break+1 : EndIf
  If break=4 Then Delete Each feldchen : Return 0
  break=0
  If endx>0 Then
   If tmpfeld(endx-1,endy)=0 Then break=break+1
  Else : break=break+1 : EndIf
  If endx<max Then
   If tmpfeld(endx+1,endy)=0 Then break=break+1
  Else : break=break+1 : EndIf
  If endy>0 Then
   If tmpfeld(endx,endy-1)=0 Then break=break+1
  Else : break=break+1 : EndIf
  If endy<max Then
   If tmpfeld(endx,endy+1)=0 Then break=break+1
  Else : break=break+1 : EndIf
  If break=4 Then Delete Each feldchen : Return 0
 Delete Each feldchen : anz=0
 f.feldchen=New feldchen
 f\koo[1]=startx : f\koo[2]=starty : f\no=0
 f\idno=0 : f\fatherno=-1
 searchno=0

 While need=0
  For f.feldchen=Each feldchen
   If f\no=searchno Then
    If f\koo[1]>0 Then
     If tmpfeld(f\koo[1]-1,f\koo[2])=1 Then
      createfeld(f\koo[1]-1,f\koo[2],f\no+1,f\idno,anz+1) : anz=anz+1
      tmpfeld(f\koo[1]-1,f\koo[2])=2
     EndIf
    EndIf
    If f\koo[1]<max Then
     If tmpfeld(f\koo[1]+1,f\koo[2])=1 Then
      createfeld(f\koo[1]+1,f\koo[2],f\no+1,f\idno,anz+1) : anz=anz+1
      tmpfeld(f\koo[1]+1,f\koo[2])=2
     EndIf
    EndIf
    If f\koo[2]>0 Then
     If tmpfeld(f\koo[1],f\koo[2]-1)=1 Then
      createfeld(f\koo[1],f\koo[2]-1,f\no+1,f\idno,anz+1) : anz=anz+1
      tmpfeld(f\koo[1],f\koo[2]-1)=2
     EndIf
    EndIf
    If f\koo[2]<max Then
     If tmpfeld(f\koo[1],f\koo[2]+1)=1 Then
      createfeld(f\koo[1],f\koo[2]+1,f\no+1,f\idno,anz+1) : anz=anz+1
      tmpfeld(f\koo[1],f\koo[2]+1)=2
     EndIf
    EndIf
   EndIf
  Next
   need=1
   For x=0 To max
   For y=0 To max
    If tmpfeld(x,y)=1 Then need=0
   Next
   Next
   For f.feldchen=Each feldchen
    If f\koo[1]=endx And f\koo[2]=endy Then need=1
   Next
 Wend

 For f.feldchen=Each feldchen
  If f\koo[1]=endx And f\koo[2]=endy Then
   f\wayto=1 : dist=f\no
   findparent(f\fatherno)
   Exit
  EndIf
 Next
 For f.feldchen=Each feldchen
  If f\wayto=0 Then Delete f.feldchen
 Next
 Return dist
End Function

Function createfeld(x,y,n,p,i)
 f.feldchen=New feldchen
 f\koo[1]=x : f\koo[2]=y : f\no=n
 f\idno=i : f\fatherno=p
End Function

Function findparent(p)
 If p<>-1 Then
  For f.feldchen=Each feldchen
   If f\idno=p Then f\wayto=1 : p=f\fatherno : Exit
  Next
  findparent(p)
 EndIf
End Function
Diese Signatur ist leer.
  • Zuletzt bearbeitet von darth am Do, Okt 04, 2007 16:58, insgesamt einmal bearbeitet
 

Matthias

 BeitragDo, Okt 04, 2007 15:56
Antworten mit Zitat
Benutzer-Profile anzeigen
Hay. Im grunde genommen habe ich überhaupt nichts gegen neue Ideen. Aber hier einen Code zu posten der nicht einmal fuctioniert finde ich nicht gerade lustig.
Es ging hier in diesem Thread darum die Einsatzmöglichkeit des Pfadfinding zu demonstrieren.

@darth gamer
Bitte mach dazu auch noch ein Beispiel. Wie zb. ein Objekt deinen gefundenen Weg entlang läuft.

Achja in Zeile
Code: [AUSKLAPPEN]

 If f\ko[1]=endx And f\ko[2]=endy Then need=1


gibt es einen Fehler.

darth

 BeitragDo, Okt 04, 2007 16:54
Antworten mit Zitat
Benutzer-Profile anzeigen
geeez -.- nu hab ich den code so oft bearbeitet, dass er wieder falsch ist.
tut mir leid, ich werde ihn umgehend korrigieren...

jop, hattest recht... hab beim überarbeiten eine zeile gelöscht die ziemlich wichtig ist.
"searchno=searchno+1"
Code: [AUSKLAPPEN]
Graphics 800,600

Type feldchen
 Field koo[2]
 Field no
 Field idno
 Field fatherno
 Field wayto
End Type

Global max=10
Dim tmpfeld(max,max)
 For x=0 To max : For y=0 To max
  tmpfeld(x,y)=1 ;0 falls unbegehbar...
 Next : Next
  ;tmpfeld(2,2)=0
  ;tmpfeld(2,3)=0
  ;tmpfeld(2,4)=0
  ;tmpfeld(3,4)=0
  ;tmpfeld(4,4)=0
  ;tmpfeld(4,3)=0
  ;tmpfeld(4,2)=0
  ;tmpfeld(3,2)=0

pfadlaenge=findpath(3,3,6,4)
 For x=0 To max : For y=0 To max
  Rect x*20,y*20,20,20,(2-tmpfeld(x,y))
 Next : Next
 For f.feldchen=Each feldchen
  Rect f\koo[1]*20+2,f\koo[2]*20+2,16,16,0
  Text f\koo[1]*20,f\koo[2]*20,f\no
 Next
 Flip 0

 X_aktuell=3 : Y_aktuell=3
 endx=6 : endy=4
 If pfadlaenge<>0 Then
  While X_aktuell<>endx Or Y_aktuell<>endy
   f.feldchen=First feldchen
    f=After f
    X_aktuell=f\koo[1] : Y_aktuell=f\koo[2]
    timer=MilliSecs() : While MilliSecs()-timer<250 : Wend ;kleine Schleife zur "verlangsamung" der aktion
   f=Before f : Delete f.feldchen
   Rect X_aktuell*20+5,Y_aktuell*20+5,10,10,0
  Wend
 EndIf
WaitKey() : End

Function findpath(startx,starty,endx,endy)
  break=0
  If startx>0 Then
   If tmpfeld(startx-1,starty)=0 Then break=break+1
  Else : break=break+1 : EndIf
  If startx<max Then
   If tmpfeld(startx+1,starty)=0 Then break=break+1
  Else break=break+1 : EndIf
  If starty>0 Then
   If tmpfeld(startx,starty-1)=0 Then break=break+1
  Else : break=break+1 : EndIf
  If starty<max Then
   If tmpfeld(startx,starty+1)=0 Then break=break+1
  Else : break=break+1 : EndIf
  If break=4 Then Delete Each feldchen : Return 0
  break=0
  If endx>0 Then
   If tmpfeld(endx-1,endy)=0 Then break=break+1
  Else : break=break+1 : EndIf
  If endx<max Then
   If tmpfeld(endx+1,endy)=0 Then break=break+1
  Else : break=break+1 : EndIf
  If endy>0 Then
   If tmpfeld(endx,endy-1)=0 Then break=break+1
  Else : break=break+1 : EndIf
  If endy<max Then
   If tmpfeld(endx,endy+1)=0 Then break=break+1
  Else : break=break+1 : EndIf
  If break=4 Then Delete Each feldchen : Return 0
 Delete Each feldchen : anz=0
 f.feldchen=New feldchen
 f\koo[1]=startx : f\koo[2]=starty : f\no=0
 f\idno=0 : f\fatherno=-1
 searchno=0

 While need=0
  For f.feldchen=Each feldchen
   If f\no=searchno Then
    If f\koo[1]>0 Then
     If tmpfeld(f\koo[1]-1,f\koo[2])=1 Then
      createfeld(f\koo[1]-1,f\koo[2],f\no+1,f\idno,anz+1) : anz=anz+1
      tmpfeld(f\koo[1]-1,f\koo[2])=2
     EndIf
    EndIf
    If f\koo[1]<max Then
     If tmpfeld(f\koo[1]+1,f\koo[2])=1 Then
      createfeld(f\koo[1]+1,f\koo[2],f\no+1,f\idno,anz+1) : anz=anz+1
      tmpfeld(f\koo[1]+1,f\koo[2])=2
     EndIf
    EndIf
    If f\koo[2]>0 Then
     If tmpfeld(f\koo[1],f\koo[2]-1)=1 Then
      createfeld(f\koo[1],f\koo[2]-1,f\no+1,f\idno,anz+1) : anz=anz+1
      tmpfeld(f\koo[1],f\koo[2]-1)=2
     EndIf
    EndIf
    If f\koo[2]<max Then
     If tmpfeld(f\koo[1],f\koo[2]+1)=1 Then
      createfeld(f\koo[1],f\koo[2]+1,f\no+1,f\idno,anz+1) : anz=anz+1
      tmpfeld(f\koo[1],f\koo[2]+1)=2
     EndIf
    EndIf
   EndIf
  Next
   need=1
   For x=0 To max
   For y=0 To max
    If tmpfeld(x,y)=1 Then need=0
   Next
   Next
   For f.feldchen=Each feldchen
    If f\koo[1]=endx And f\koo[2]=endy Then need=1
   Next
  If nead=0 Then searchno=searchno+1
 Wend

 For f.feldchen=Each feldchen
  If f\koo[1]=endx And f\koo[2]=endy Then
   f\wayto=1 : dist=f\no
   findparent(f\fatherno)
   Exit
  EndIf
 Next
 For f.feldchen=Each feldchen
  If f\wayto=0 Then Delete f.feldchen
 Next
 Return dist
End Function

Function createfeld(x,y,n,p,i)
 f.feldchen=New feldchen
 f\koo[1]=x : f\koo[2]=y : f\no=n
 f\idno=i : f\fatherno=p
End Function

Function findparent(p)
 If p<>-1 Then
  For f.feldchen=Each feldchen
   If f\idno=p Then f\wayto=1 : p=f\fatherno : Exit
  Next
  findparent(p)
 EndIf
End Function

never change a running system :O nächstesmal lass ich meine coole goto schleife drin!

[EDIT, 11.04.2010:]

Hallo,

hmm, ich hoffe das pusht den Thread nicht unnötig, ich versuch es einfach mal.

Eigentlich erstaunlich wie einfach reizbar ich damals war Smile vor allem wo ich doch heute so ein gemütlicher Kerl bin. Ebenso erstaunlich wie furchtbar mein Codestil war, man beachte die Funktion "FindParent", man hätte viel Rechenzeit sparen können, wenn man einfach den Parent gespeichert hätte. Aber iirc konnte ich damals nicht wirklich mit Types umgehen Smile
Nun, der Grund für das Edit hier ist, dass ich den Code aus gewissen Gründen wieder ausgegraben habe, feststellte dass er ein absolutes (undurchsichtiges) Monstrum ist und ihn umgeschrieben habe. Vom Prinzip her funktioniert er genau gleich, vom Startpunkt aus wird sukzessiv weitergegangen (solange die Felder noch nicht begangen wurden) bis man das Ziel erreicht. Ich bin mir nicht sicher, wieviel dies mit A* zu tun hat, aber so vom Überfliegen der Tutorials zu diesem Thema müsste es etwa das gleiche sein (mit Ausnahme, dass ich mit einem Array arbeite und nicht mit open und closed Lists).

Der neue Code arbeitet mit zwei Types, einem temporären ArbeitsType (Node) und einem PfadType (PathNode), zur Berechnung des Wegs ruft man die Funktion getPath(xStart, yStart, xStop, yStop) auf, und kriegt dann den ersten Pfadpunkt des Wegs. Die Pfadpunkte sind über einen Link zusammengehängt.
Anm: Bei der Funktion getPath() werden alle Nodes und PathNodes gelöscht, das Löschen der Nodes ist wichtig (führt möglicherweise zu Fehlern wenn man sie leben lässt), das Löschen der PathNodes ist nicht zwingend notwendig und verhindert, dass mehrere Pfade gleichzeitig berechnet werden können. Sollte dies notwendig sein, muss man die Zeil entfernen, da man sowieso den Startpunkt der LinkedList erhält, ist es nicht notwendig alle anderen zu löschen. Ich mache dies, um Speicher freizukriegen...

Hier der Code (Beispiel folgt):

BlitzBasic: [AUSKLAPPEN] 
Const MAP_SIZE=10
Dim map(MAP_SIZE, MAP_SIZE)

Type Node
	Field x
	Field y
	
	Field parent.Node
	
	Field nodeCost
End Type

Type PathNode
	Field x
	Field y
	
	Field pathId
	
	Field succ.PathNode
End Type

Function drawMap()
	For x=0 To MAP_SIZE-1
		For y=0 To MAP_SIZE-1
			If map(x,y)
				Rect x*10,y*10,10,10,0
			Else
				Rect x*10,y*10,10,10
			EndIf
		Next
	Next
End Function

Function cNode.Node(x, y, parent.Node, cost)
	Local n.Node=New Node
	
	n\x=x
	n\y=y
	
	n\parent=parent
	
	n\nodeCost=cost
	
	Return n
End Function

Function cPathNode.PathNode(x, y, id, succ.PathNode)
	Local p.PathNode=New PathNode
	
	p\x=x
	p\y=y
	
	p\pathId=id
	
	p\succ=succ
	
	Return p
End Function

Function getPath.PathNode(xStart, yStart, xStop, yStop)
	Delete Each Node
	Delete Each PathNode
	
	Local iterNode.Node=findPath(xStart, yStart, xStop, yStop)
	Local p.PathNode=Null
	
	;Kein Weg gefunden
	If iterNode=Null
		Return Null
	EndIf
	
	While True
		p=cPathNode(iterNode\x, iterNode\y, iterNode\nodeCost, p)
		
		If p\x=xStart And p\y=yStart
			Exit
		EndIf
		
		iterNode=iterNode\parent
	Wend
	
	Delete Each Node
	
	Return p
End Function

Dim mapCopy(MAP_SIZE, MAP_SIZE)
Function findPath.Node(xStart, yStart, xStop, yStop)
	Local nStart.Node=cNode(xStart, yStart, Null, cost)
	Local actCost=0, n.Node, nNew.Node, addCount
	
	Local dX[4], dY[4]
	dX[0]=-1
	dX[1]=1
	dY[2]=-1
	dY[2]=1
	
	For x=0 To MAP_SIZE
		For y=0 To MAP_SIZE
			If map(x,y)
				If Not (x=xStart And y=yStart)
					mapCopy(x, y)=True
				EndIf
			EndIf
		Next
	Next
	
	While True
		addCount=0
		
		For n=Each Node
			If n\nodeCost=actCost
				For i=0 To 4
					If testStep(n\x+dX[i], n\y+dY[i])
						nNew=cNode(n\x+dX[i], n\y+dY[i], n, n\nodeCost+1)
						mapCopy(n\x+dX[i], n\y+dY[i])=False
						
						addCount=addCount+1
						
						If nNew\x=xStop And nNew\y=yStop
							Return nNew
						EndIf
					EndIf
				Next
			EndIf
		Next
		
		;Kein Weg gefunden
		If addCount=0
			Return Null
		EndIf
		
		actCost=actCost+1
	Wend
End Function

Function testStep(x, y)
	If x<0
		Return False
	EndIf
	
	If x>=MAP_SIZE
		Return False
	EndIf
	
	If y<0
		Return False
	EndIf
	
	If y>=MAP_SIZE
		Return False
	EndIf
	
	Return mapCopy(x, y)
End Function


Oben steht die blanke Funktion, alles Notwendige ist darin enthalten. Die Map MUSS in dem angelegten Dim gespeichert werden, da diese in die mapCopy überschrieben wird (könnte man in BB Arrays in Funktionen übergeben, wäre das einfacher lösbar, oh well..), dazu muss mapCopy natürlich gleicher Grösse sein. Dazu ist die Konstante "MAP_SIZE" drin.
Anm: Dies führt dazu, dass nur quadratische Maps möglich sind, aber die Änderung zu anderen Strukturen bedarf nur geringen Anpassungen, die ich gerne anderen überlasse :>

Und nun wie versprochen ein Anwendungsbeispiel (obigen Code einfach dazu kopieren, damit Types, Konstanten, Funktionen vorhanden sind):

BlitzBasic: [AUSKLAPPEN] 
;*************
; TESTPROGRAM
;*************

Graphics 800,600,0,2
SetBuffer BackBuffer()

For x=0 To MAP_SIZE-1
	For y=0 To MAP_SIZE-1
		map(x, y)=True
	Next
Next
map(5, 3)=False
map(6, 4)=False
map(6, 5)=False

tick=MilliSecs()
Local startNode.PathNode=getPath(3, 3, 6, 7)
Local p.PathNode
tock=MilliSecs()

Local timer=CreateTimer(60)
While Not KeyHit(1)
	drawMap()
	
	Text 10,580,"Found in "+(tock-tick)+"ms"
	
	p=startNode
	While p<>Null
		Text p\x*10, p\y*10, p\pathId
		
		p=p\succ
	Wend
	
	Flip 0
	WaitTimer(timer)
	Cls
Wend
End


Soviel zu dem Update. Ich weiss nicht wieviel es nützt, wie oft dieser Thread noch besucht wird, aber ich wollte mal eine meiner (vielen..) Jugendsünden beheben Smile Mal sehn ob ich noch andere lustige Dinge von mir im Codearchiv finde. Aber hier ist nun mal wieder Schluss,

MfG,
Darth
  • Zuletzt bearbeitet von darth am So, Apr 11, 2010 13:55, insgesamt 2-mal bearbeitet

hectic

Sieger des IS Talentwettbewerb 2006

BeitragDo, Okt 04, 2007 20:07
Antworten mit Zitat
Benutzer-Profile anzeigen
darth gamer, kannst du aus deiner Funktion noch ein Beispielprogramm schreiben, so mit Rects, Ovals und einer kleinen Beispiel-Dim-map, denn ich gehe aus deiner Funktionsbeschreibung von aus, dass der Code so nicht funktionieren kann.

Und was soll ''bissl unsauber - wollte aber keine WHILE'' bedeuten? Wink
Download der Draw3D2 V.1.1 für schnelle Echtzeiteffekte über Blitz3D

darth

 BeitragDo, Okt 04, 2007 21:09
Antworten mit Zitat
Benutzer-Profile anzeigen
@hectic:
der letzte beitrag von mir (also der letzte vor dem da, also der über deinem) enthält doch ein komplettes beispiel mit dim map :O wo liegt das problem?
egal, der code geht, ich verwendete ihn in einem meiner spiele und hatte nie probleme.
das unsaubere (im alten code) ist/war die "goto-schleife". aber (was jetzt eben nicht mehr ist) ich wollte dort keine while schleife einfügen, habs jetzt aber doch gemacht. das is alles...
Diese Signatur ist leer.

hectic

Sieger des IS Talentwettbewerb 2006

BeitragFr, Okt 05, 2007 0:20
Antworten mit Zitat
Benutzer-Profile anzeigen
Hab wohl den ersten Code getestet. Und meine Vermutung (hab die Dim extra noch angepasst) hat sich nicht bestätigt.
Download der Draw3D2 V.1.1 für schnelle Echtzeiteffekte über Blitz3D

Neue Antwort erstellen


Übersicht BlitzBasic Codearchiv

Nach Oben

Gehe zu:

Powered by phpBB © 2001 - 2006, phpBB Group