 |
Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
|
| Vorheriges Thema anzeigen :: Nächstes Thema anzeigen |
| Autor |
Nachricht |
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
 Verfasst am: 18.03.2013, 22:03 Titel: Zufalls Labyrinth |
 |
|
Hi zusammen,
ich versuche mich gerade mit der Generierung eines Zufalls-Labyrinth, leider hab ich da wohl noch ein paar kleinere Probleme...
Um zu prüfen ob alle Wege erreichbar sind hab ich eine fillPath Funktion zum testen wo mir dann aufgefallen ist das bei mir oft ganze Bereiche verschlossen sind (was nicht so schlimm wäre), leider erreicht man dann leider auf keinem Weg vom Start aus das Ziel was am ende wohl fatal wäre...
Hier mal zwei Beispiele: (grün ist start, rot ist ziel, weiss ist wand, grau ist weg bzw hellblau weg vom fillpath)
Am besten wäre es wenn das Labyrinth immer so generiert wird wie dieses zum Beispiel:
Seht ihr irgendwo einen Weg das zu erreichen?
Hier mal mein Beispielcode:
| Code: |
Randomize Timer
type Vector2
X as Integer
Y as Integer
end type
Function getRandom(Byval min as Integer, Byval max as Integer, Byval granularity as Integer = 1) as Integer
Dim emergencyexit as Integer
Dim rndnum as Integer
do
rndnum = int(rnd*(max-(min-1)))
If (rndnum mod granularity) = 0 Then return rndnum
emergencyexit += 1
loop while emergencyexit < 99
return 0
End Function
Function genMaze(Byval sizeW as Integer, Byval sizeH as Integer, Byval start as Vector2, Byval goal as Vector2) as byte ptr
Dim MazeP as byte ptr = NEW byte[sizeW*sizeH]
Dim minLength as Integer = 1
Dim maxLength as Integer
Dim granularity as Integer
Dim destination as Integer
Dim as Integer X,Y,L,dX,dY
MazeP[start.X + (start.Y * sizeW)] = &h02 'start
MazeP[goal.X + (goal.Y * sizeW)] = &h03 'goal
For G as Integer = 4 to 1 step -1
granularity = 2 ^ G
For W as Integer = 0 to (sizeW*sizeH)
X = getRandom(0,sizeW-1,granularity)
Y = getRandom(0,sizeH-1,granularity)
destination = getRandom(0,3)
Select Case destination
Case 0 'Left
maxLength = sizeW/2
L = getRandom(minLength,maxLength)
dX = -1 : dY = 0
Case 1 'Right
maxLength = sizeW/2
L = getRandom(minLength,maxLength)
dX = 1 : dY = 0
Case 2 'Up
maxLength = sizeH/2
L = getRandom(minLength,maxLength)
dX = 0 : dY = -1
Case 3 'Down
maxLength = sizeH/2
L = getRandom(minLength,maxLength)
dX = 0 : dY = 1
End Select
For ll as Integer = 1 to L
If (MazeP[X+(Y*sizeW)]) Then Exit For
MazeP[X+(Y*sizeW)] = 1
X += dX : Y += dY
If (X < 0) OR (X >= sizeW) OR (Y < 0) OR (Y >= sizeH) Then Exit For
Next ll
Next W
Next G
return MazeP
End Function
Sub fillPath(byref Maze as byte ptr, byval sizeW as Integer, byval sizeH as Integer, byval posX as Integer, byval posY as Integer, byval init as Integer = 0)
static fin as Integer
Dim mappos as Integer
mappos = posX+(posY*sizeW)
If init then fin = 0
If Maze[mappos]=&h00 Then Maze[mappos]=&h20' :?posX,posY
If Maze[mappos]=&h03 Then fin=1
If fin Then Exit Sub
If (posX > 0) and Maze[mappos-1]=&h00 Then fillPath(Maze,sizeW,sizeH,posX-1,posY)
If (posY > 0) and Maze[mappos-sizeW]=&h00 Then fillPath(Maze,sizeW,sizeH,posX,posY-1)
If (posX < (sizeW-1)) and Maze[mappos+1]=&h00 Then fillPath(Maze,sizeW,sizeH,posX+1,posY)
If (posY < (sizeH-1)) and Maze[mappos+sizeW]=&h00 Then fillPath(Maze,sizeW,sizeH,posX,posY+1)
End Sub
screenres 800,600,32
Dim myMaze as byte ptr
Dim as Integer C, F
Dim as Vector2 S, G
do
S = type(rnd*80,rnd*60)
G = type(rnd*80,rnd*60)
myMaze = genMaze(80,60,S,G)
fillPath(myMaze,80,60,S.X,S.Y,1)
for y as integer=0 to 59
for x as integer=0 to 79
F = myMaze[x+(y*80)]
Select Case F
Case &h00 'Floor
C = &h222222
Case &h01 'Wall
C = &hFFFFFF
Case &h02 'Start
C = &h00FF00
Case &h03 'Goal
C = &hFF0000
Case &h20 'test path
C = &h3333FF
Case Else ' error?
C = &hFF8800
End Select
Line(x*10,y*10)-(9+(x*10),9+(y*10)),C,bf
next x
next y
sleep
Delete[] myMaze
Loop until multikey(&h01) |
_________________
 |
|
| Nach oben |
|
 |
nemored
Anmeldungsdatum: 22.02.2007
Beiträge: 4710
Wohnort: ~/
|
| Verfasst am: 18.03.2013, 23:07 Titel: |
|
|
Ich habe mal wegen eines Wegsuch-Algorithmus ein Labyrinth erstellt, da habe ich ganz einfach anschließend einen zufälligen Weg hindurch freigeräumt  so war zumindest sichergestellt, dass es mindestens einen möglichen Weg gibt.
_________________
Deine Chance beträgt 1:1000. Also musst du folgendes tun: Vergiss die 1000 und konzentriere dich auf die 1. |
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 19.03.2013, 01:46 Titel: |
|
|
Wäre vielleicht eine Alternative Wert
hab noch eine Weile an meinem Code gebastelt und lasse mir das Labyrinth neu generieren falls das Ziel vom Start aus nicht erreichbar ist...
Muss mir jetzt nur noch etwas Überlegen für einen Fall wie zB hier wo der Start einfach zu nah am Ziel ist...
und es fehlt mir vielleicht noch ein schönes A* Pathfinding Beispiel
| Code: | Randomize Timer
#Define MazeFloor &h00
#Define MazeWall &h01
#Define MazeStart &h02
#Define MazeGoal &h03
#Define MazePath &h20
Function getRandom(Byval min as Integer, Byval max as Integer, Byval granularity as Integer = 1) as Integer
'Dim emergencyexit as Integer
Dim rndnum as Integer
'do
rndnum = int(rnd*(max-(min-1)))
'If (rndnum mod granularity) = 0 Then return rndnum
'emergencyexit += 1
'loop while emergencyexit < 99
return rndnum'min
End Function
Type Vector2
X as Integer
Y as Integer
End Type
Type tMaze
'Private:
MazeP as byte ptr
MazeW as Integer 'Width
MazeH as Integer 'Height
MazeC as Integer 'control flag
MazeS as Vector2 'Start position
MazeG as Vector2 'goal/exit
Declare Sub fillwithWalls(byval minLength as Integer, byval maxLength as Integer, byval granularity as Integer, byval numWalls as Integer)
'Public:
Declare Sub genMaze(byval size as Vector2, byval start as Vector2, byval goal as Vector2)
Declare Sub genMaze(byval sizeW as Integer, byval sizeH as Integer)
Declare Sub delMaze()
Declare Sub fillPath(byval position as Vector2)
Declare Sub drawMaze()
End Type
Sub tMaze.fillPath(byval position as Vector2)
If MazeC Then Exit Sub
Dim mappos as Integer
Dim maptype as Integer
Dim FP as Integer
mappos = position.X+(position.Y*MazeW)
If MazeP[mappos]=MazeFloor Then MazeP[mappos]=&h20
If (position.X > 0) Then
maptype = MazeP[mappos-1]
If maptype = MazeFloor Then FP = FP OR &b0001
If maptype = MazeGoal Then MazeC = 1
End If
If (position.Y > 0) Then
maptype = MazeP[mappos-MazeW]
If maptype = MazeFloor Then FP = FP OR &b0010
If maptype = MazeGoal Then MazeC = 1
End If
If (position.X < (MazeW-1)) Then
maptype = MazeP[mappos+1]
If maptype = MazeFloor Then FP = FP OR &b0100
If maptype = MazeGoal Then MazeC = 1
End If
If (position.Y < (MazeH-1)) Then
maptype = MazeP[mappos+MazeW]
If maptype = MazeFloor Then FP = FP OR &b1000
If maptype = MazeGoal Then MazeC = 1
End If
If (FP and &b0001) Then fillPath(type(position.X-1,position.Y))
If (FP and &b0010) Then fillPath(type(position.X,position.Y-1))
If (FP and &b0100) Then fillPath(type(position.X+1,position.Y))
If (FP and &b1000) Then fillPath(type(position.X,position.Y+1))
End Sub
Sub tMaze.drawMaze()
Dim C as UInteger
Dim F as byte
screenlock
for y as integer=0 to MazeH-1
for x as integer=0 to MazeW-1
F = MazeP[x+(y*MazeW)]
Select Case F
Case &h00 'Floor
C = &h222222
Case &h01 'Wall
C = &hFFFFFF
Case &h02 'Start
C = &h00FF00
Case &h03 'Goal
C = &hFF0000
Case &h20 'test path
C = &h3333FF
Case Else ' error?
C = &hFF8800
End Select
Line(x*10,y*10)-(9+(x*10),9+(y*10)),C,bf
next x
next y
screenunlock
End Sub
Sub tMaze.fillwithWalls(byval minLength as Integer, byval maxLength as Integer, byval granularity as Integer, byval numWalls as Integer)
Dim mappos as Integer
Dim rndpos as Vector2
Dim rnddir as Integer
Dim rndlen as Integer
Dim as Integer dX, dY
For NW as Integer = 1 to numWalls
rndpos.X = granularity * getRandom(0,(MazeW-1)/granularity)
rndpos.Y = granularity * getRandom(0,(MazeH-1)/granularity)
rnddir = getRandom(0,3)
rndlen = granularity * getRandom(minLength,maxLength) + 1
Select Case rnddir
Case 0 'North/Up
dX = 0 : dY = -1
Case 1 'East/Right
dX = 1 : dY = 0
Case 2 'South/Down
dX = 0 : dY = 1
Case 3 'West/Left
dX = -1 : dY = 0
End Select
For L as Integer = 0 to rndLen
mappos = rndpos.X + (rndpos.Y * MazeW)
If MazeP[mappos] Then Exit For
MazeP[mappos] = MazeWall
rndpos.X += dX : rndpos.Y += dY
If (rndpos.X < 0) OR (rndpos.Y < 0) OR (rndpos.X >= MazeW) OR (rndpos.Y >= MazeH) Then Exit For
Next L
Next NW
End Sub
Sub tMaze.genMaze(byval sizeW as Integer, byval sizeH as Integer)
Dim rndStart as Vector2 = type(rnd*sizeW,rnd*sizeH)
Dim rndGoal as Vector2 = type(rnd*sizeW,rnd*sizeH)
genMaze(type<Vector2>(sizeW,sizeH),rndStart,rndGoal)
End Sub
Sub tMaze.genMaze(byval size as Vector2, byval start as Vector2, byval goal as Vector2)
Dim mappos as Integer
MazeW = 0
MazeH = 0
MazeS = type(0,0)
MazeG = type(0,0)
MazeC = 0
Do
If MazeP Then delMaze()
MazeW = size.X : MazeH = size.Y
MazeP = NEW byte[MazeW * MazeH]
mappos = start.X + (start.Y * MazeW)
If (mappos >= 0) and (mappos < (MazeW * MazeH)) Then
MazeP[mappos] = MazeStart
MazeS = start
Else
MazeP[0] = MazeStart
MazeS = type(0,0)
End If
mappos = goal.X + (goal.Y * MazeW)
If (mappos >= 0) and (mappos < (MazeW * MazeH)) and ((goal.X<>start.X) OR (goal.Y<>start.Y)) Then
MazeP[mappos] = MazeGoal
MazeG = goal
Else
MazeP[(MazeW*MazeH)-1] = MazeGoal
MazeG = type(MazeW-1,MazeH-1)
End If
fillwithWalls( 4, 6, 16, 100)
fillwithWalls( 2, 6, 8, 200)
fillwithWalls( 2, 4, 4, 300)
fillwithWalls( 1, 4, 2, MazeW*MazeH)
fillPath(MazeS)
If MazeC Then Exit Do
Loop
End Sub
Sub tMaze.delMaze()
If MazeP Then Delete[] MazeP
MazeW = 0
MazeH = 0
MazeS = type(0,0)
MazeG = type(0,0)
MazeC = 0
End Sub
screenres 800,600,32
Dim myMaze as tMaze
Do
myMaze.genMaze(80,60)
myMaze.drawMaze()
sleep
myMaze.delMaze()
Loop until multikey(&h01)
|
_________________
|
|
| Nach oben |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007
Beiträge: 1839
Wohnort: [JN58JR]
|
| Verfasst am: 19.03.2013, 01:55 Titel: |
|
|
Vorschlag. Wie wäre es denn, wenn du einen Path zufällig generieren lässt, und um diesen herum "bullshit" setzen lässt.
damit hast du immer einen funktionierenden Path, um den du herum alles mögliche bastelst, das irreführend oder sogar erfolgversprechend werden könnte, anstat per zufall etwas zu generieren.
was meinst du mit "und es fehlt mir vielleicht noch ein schönes A* Pathfinding Beispiel" ?
PS: Code-Collaps wäre wirklich langsam sinvoll. Diese Giga-Postings nehmen immer mehr zu.
MfG
TPM
_________________
[ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ] |
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 19.03.2013, 02:05 Titel: |
|
|
Mir kam die Idee ein kleines Dungeon/Labyrinth zu erstellen, wollte aber keine 'Level' machen und dachte mir ich bediene mich eines Maze-Algorythmus . Fand anfänglich aber nur auf 'Zellen' aufgebaute:
Hab den Code hier dann mithilfe dieser PDF erstellt die ich gefunden habe:
https://www2.cs.fau.de/EN/teaching/WS2005/GameAlgHS/download/Rathmann-Prozedurale_Labyrinth-Generierung.pdf
Schien mir am geeignetsten, die Idee zufällig einen Path zu erstellen und drumherum zu 'Bauen' wäre ebenfalls einen Versuch Wert, scheint mir aber mindestens genauso 'komplex' zu werden...
btw: hab selbst gar nicht gemerkt das der Code schon wieder so lang geworden ist...
| Zitat: | | was meinst du mit "und es fehlt mir vielleicht noch ein schönes A* Pathfinding Beispiel" ? |
http://de.wikipedia.org/wiki/A*-Algorithmus
_________________
|
|
| Nach oben |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007
Beiträge: 1839
Wohnort: [JN58JR]
|
| Verfasst am: 19.03.2013, 02:10 Titel: |
|
|
in der wiki gibts doch n beispiel ... is zwar nicht fb, aber der source sollte sehr leicht in fb zu integrieren sein.
MfG
TPM
_________________
[ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ] |
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 19.03.2013, 14:06 Titel: |
|
|
Hab versucht ein klein wenig zu optimieren, sollte eigentlich optimal funktionierten (tut es bei kleinen Labyrinthen auch) aber versuche ich ein größeres wie im Beispielcode (400,300) zu erzeugen stürzt das Programm entweder ab oder bleibt hängen...
Hab bereits mit -exx compiliert (ohne meldung) sowie den stack erhöht bzw alle möglichen stack/speicher funktionen ausgeklammert...
Auch den mit NEW reservierten Speicherbereich testweise mit allocate erzeugt (bzw callocate)...
ich finde die Ursache einfach nicht...
http://www.freebasic-portal.de/porticula/mymaze3-1603.html
im selben Atemzug wie ich den Post geschrieben habe war mir was eingefallen...
Dummerweise hab ich die map-position mit ushort's verrechnet, die positionen aber weit über die 65k grenze hinaus gingen... hab sie zu uintegern geändert und nun funktioniert es ohne weitere probleme...
sorry 
_________________
|
|
| Nach oben |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007
Beiträge: 1839
Wohnort: [JN58JR]
|
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 19.03.2013, 15:15 Titel: |
|
|
hmm... wenn ich nun nicht vorher herausgefunden hätte woran es lag, würde ich aus der Info auch nur 'speicherverletzungen' erkennen...
das optimieren aber hat sich aber ein wenig gelohnt, nun wird jedes mal ein sehr schönes Maze generiert (nach 10min auf den Screen gucken noch kein Maze mit Einschlüssen entdeckt...)
http://www.freebasic-portal.de/porticula/perfect-maze-1604.html
Edit: nu hab ich doch EIN MAL ein Einschluss gesehen (sind also doch Möglich aber sehr selten  )
Ob man das später ohne Hilfe lösen kann ?
_________________
Zuletzt bearbeitet von Eternal_pain am 19.03.2013, 15:51, insgesamt einmal bearbeitet |
|
| Nach oben |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007
Beiträge: 1839
Wohnort: [JN58JR]
|
| Verfasst am: 19.03.2013, 15:22 Titel: |
|
|
jo. das is richtig .. is ne speicherverletzung. In dem Log findest du allerdigns sogar die Orte, wo diese speicherfehler auftreten. test7.bas: zeile 138 z.B. ... anhand der info kannst doch schon deutlich zielgerichteter nach dem fehler suchen.
hinzu kommt, das dieses log dir auch sagt, was für eine art von speicherverletzung es ist.
Invalid write of size 1 ... ingültiger schreibvesuch von 1 byte länge
Address 0x459e598 is not stack'd, malloc'd or (recently) free'd ... das ganze an adresse xyz, welche nicht auf dem stack liegt, niemals allociert und oder früher wieder freigegeben wurde.
sprich, du hast versuch auf speicherbereiche zuzugreifen, wie du nie besessen hast.
Wäre also mal sinvoll, die adressen zu prüfen, welche du nutzt. Das zeug zwischen [ und ].
Einige Fehler können unter umständen nichtmal dramatisch auftreten. sondern erst in komischen fällen, was dann dazu führt, das du dich tot suchst 
MfG
TPM
_________________
[ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ] |
|
| Nach oben |
|
|
dreael
Administrator
Anmeldungsdatum: 10.09.2004
Beiträge: 2530
Wohnort: Hofen SH (Schweiz)
|
| Verfasst am: 19.03.2013, 21:55 Titel: |
|
|
Früheres QB-Projekt von mir:
http://www.dreael.ch/Deutsch/Download/Labyrinth.html
=> Damals hatte ich mich auch einmal mit passenden Algorithmen auseinandergesetzt bzw. dort selber etwas entwickelt. => Du kannst dort sogar mit einer Parameterzahl die Generierung beeinflussen.
_________________
Teste die PC-Sicherheit mit www.sec-check.net |
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 20.03.2013, 17:32 Titel: |
|
|
Anfangs hatte ich auch versucht ein wenig mehr Flexibilität einzubauen wenn es darum ging wie viel und wie lange Wände generiert werden sollen...
Bin aber immer weiter davon ab, und generiere nach 'Regeln' wie in dem oben verlinkten PDF beschrieben und erhalte inzwischen eigentlich recht tolle Labyrinthe... Einschlüsse sind selten und meistens recht klein (je größer das zu generierende Labyrinth um so höher die Möglichkeit und Größe der Einschlüsse)
Mir jedenfalls gefällt es jetzt schon ganz gut
Habe allerdings noch ein kleines Problem (hauptsächlich bei großen Labyrinthe)
Und zwar stößt meine rekursive fill-Routine (zum prüfen) bzw. der Stack irgendwann an seine Grenzen...
Hier mal ein Beispiel (Versuch) als Farbfüller, der schon sehr früh aufgibt:
| Code: |
Const scrWidth as Integer = 800
Const scrHeight as Integer = 600
Namespace scrfill
Dim pColor as Uinteger
Dim fColor as UInteger
Declare Sub fill(byval posX as Integer, byval posY as Integer, byval col as Uinteger)
Declare Sub nfill(byval posX as Integer, byval posY as Integer)
Sub fill(byval posX as Integer, byval posY as Integer, byval col as Uinteger)
pColor = point(posX,posY)
fColor = col
nfill(posX, posY)
End Sub
Sub nfill(byval posX as Integer, byval posY as Integer)
static nstack as uinteger
nstack += 1
open cons for output as #99 : print #99,nstack:close #99
if point(posX,posY) = pColor Then pset(posX,posY),fColor
If (posX > 0 ) andalso point(posX-1,posY )=pColor Then nfill(posX-1,posY )
If (posY > 0 ) andalso point(posX ,posY-1)=pColor Then nfill(posX ,posY-1)
If (posX < (scrWidth-1 )) andalso point(posX+1,posY )=pColor Then nfill(posX+1,posY )
If (posY < (scrHeight-1)) andalso point(posX ,posY+1)=pColor Then nFill(posX ,posY+1)
nstack -= 1
End Sub
End Namespace
screenres scrWidth,scrHeight,32
line(1,1)-(scrWidth-2,scrHeight-2),&hFFFFFFFF
scrfill.fill(100,100,&hFF0000)
sleep
|
Irgendeine Idee das ganze wenigstens halb oder ganz interativ zu gestalten?
_________________
|
|
| Nach oben |
|
|
nemored
Anmeldungsdatum: 22.02.2007
Beiträge: 4710
Wohnort: ~/
|
| Verfasst am: 20.03.2013, 19:07 Titel: |
|
|
evtl. eine Richtung (z. B. nach rechts) iterativ machen statt rekursiv. Und sonst gibt es natürlich auch immer noch eine BASIC-eigene Füllroutine PAINT.
edit: Es sollte auch gehen, dass du waagrecht generell iterativ vorgehst und nur bei auf/ab die Rekursion brauchst.
_________________
Deine Chance beträgt 1:1000. Also musst du folgendes tun: Vergiss die 1000 und konzentriere dich auf die 1. |
|
| Nach oben |
|
|
dreael
Administrator
Anmeldungsdatum: 10.09.2004
Beiträge: 2530
Wohnort: Hofen SH (Schweiz)
|
| Verfasst am: 20.03.2013, 19:53 Titel: |
|
|
Zu meiner seinerzeitigen Variante: Iterativer Algorithmus mit einer List, die zu Beginn 1 Position enthält, ausserdem Streichtabelle in der Grösse vom Labyrinth.
While (Liste noch nicht leer)
Algorithmus pro Iterationsschritt: Zufälliger Eintrag in Liste suchen, ebenso zufällige Richtung, die aber noch gemäss Streichtabelle noch nicht entdeckt ist. => Zu diesem Feld hin Durchgang "graben", Zielfeld streichen und auf die Liste nehmen.
Falls fürs ausgewählte Feld keine unentdeckten Nachbarfelder (Streichtabelle) mehr gibt, dann gewähltes Feld aus Liste entfernen.
Wend
=> Ergibt dann einen Lybrinth-Entstehungsprozess, der mit dem Wachstum eines Wurzelballen einer Pflanze vergleichbar ist: Jedes Ende kann wachsen, solange es noch freie Erde hat. Am Schluss wird für die Positionierung des Ein- und Ausgangs der längste Weg gesucht.
_________________
Teste die PC-Sicherheit mit www.sec-check.net |
|
| Nach oben |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007
Beiträge: 1839
Wohnort: [JN58JR]
|
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 21.03.2013, 20:47 Titel: |
|
|
Gestern Abend hatte ich noch ein paar Versuche angestellt um mich vor einer LinkedList zu drücken (weil ich damit immer so meine Probleme habe) hat zwar funktioniert war aber furchtbar langsam (mehrere Minuten)
Hab mich dann nun doch noch dazu durchgerungen eine LinkedList zu basteln, damit geht es jetzt angemessener Geschwindigkeit schon ganz gut (getestet mit einem 1920,1080 Labyrinth (mehr kann ich auf meinem Schirm nicht anzeigen ))
Auch wenn es funktioniert, bin ich mir meiner LinkedList nicht zu hundert prozent sicher (trau mir da nicht ganz )
speziell die DelEntry und DestroyList
Wenn da einer 'nen kurzen Blick drauf werfen mag?!
| Code: |
Type tListNode
NextEntry as tListNode ptr
PrevEntry as tListNode ptr
EntryValue as Integer
End Type
Type tList
Declare Sub AddEntry(byval Value as Integer)
Declare Sub DelEntry(byref ListNode as tListNode ptr)
Declare Sub DestroyList()
FirstEntry as tListNode ptr
LastEntry as tListNode ptr
End Type
Sub tList.AddEntry(byval Value as Integer)
Dim NewEntry as tListNode ptr = NEW tListNode
NewEntry -> EntryValue = Value
If (LastEntry = 0) Then
FirstEntry = NewEntry
LastEntry = NewEntry
Exit Sub
End If
If LastEntry Then
NewEntry -> PrevEntry = LastEntry
LastEntry -> NextEntry = NewEntry
LastEntry = NewEntry
End If
End Sub
Sub tList.DestroyList()
Dim ThisNode as tListNode ptr
Dim TempNode as tListNode ptr
ThisNode = LastEntry
Do
If ThisNode Then
TempNode = ThisNode -> PrevEntry
DelEntry(ThisNode)
ThisNode = TempNode
End If
Loop while ThisNode
End Sub
Sub tList.DelEntry(byref ListNode as tListNode ptr)
If ListNode -> NextEntry Then ListNode -> NextEntry -> PrevEntry = ListNode -> PrevEntry
If ListNode -> PrevEntry Then ListNode -> PrevEntry -> NextEntry = ListNode -> NextEntry
If FirstEntry = ListNode Then FirstEntry = FirstEntry -> NextEntry
If LastEntry = ListNode Then LastEntry = LastEntry -> PrevEntry
Delete ListNode
End Sub
|
Den ganzen Mazecode gibts dann hier (zum testen...)
http://www.freebasic-portal.de/porticula/mymaze4-1607.html
@ThePuppetMaster
auf dein PathFind-Code werd ich mich direkt mal draufstürzen 
Danke für die Mühe...
_________________
|
|
| Nach oben |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007
Beiträge: 1839
Wohnort: [JN58JR]
|
| Verfasst am: 21.03.2013, 22:37 Titel: |
|
|
reiner info-code:
einfach last als temp ptr nutzen. da die liste eh schlussendlich leer is (0) ists egal welche var man nimmt.
| Code: |
Sub list_destroy(byref first, byref last)
do until first = 0
last = first->next
deallocate(first)
first = last
loop
end sub
|
1. schaun, ob nach dem item noch eines kommt. wenn ja, dan dieses darüber informieren, das sein vorheriger jetzt der vorherige vom item is
2. selbes mit dem vorherigem vom item
3. schaun, ob das item eventuell das erste is, wenn ja, dann bei first das nächste vom item setzen
4. selbes mit dem letztem
5. item löschen
6. fertig
7. freuen
| Code: |
sub list_del(byval item, byref first byref last)
if item->next <> 0 then item->next->prev = item->prev
if item->prev <> 0 then item->prev->next = item->next
if first = item then first = item->next
if last = item then last = item->prev
deallocate(item)
end sub
|
so kannst du eigentlich jede double-linked list leeren und items daraus löschen.
MfG
TPM
EDIT: bei deinem clear gibts n prob. du schreibst
| Code: |
'...
Loop while ThisNode
|
das is GANZ GANZ schlecht.
wenn die liste leer is, dann durchläuft deine do-loop min. 1x die schleife.
besser ist
| Code: |
do while ThisNode
'...
|
hier wird bei 0 schon die schleife übersprungen und nicht erst min. 1x durchlaufen.
_________________
[ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ] |
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 22.03.2013, 14:47 Titel: |
|
|
| ThePuppetMaster hat Folgendes geschrieben: |
EDIT: bei deinem clear gibts n prob. du schreibst
| Code: |
'...
Loop while ThisNode
|
das is GANZ GANZ schlecht.
wenn die liste leer is, dann durchläuft deine do-loop min. 1x die schleife.
besser ist
| Code: |
do while ThisNode
'...
|
hier wird bei 0 schon die schleife übersprungen und nicht erst min. 1x durchlaufen. |
Das war jetzt kein wirkliches Problem, aber sieht letztenendes besser aus:
| Code: |
Sub tList.DestroyList()
while FirstEntry
LastEntry = FirstEntry -> NextEntry
Delete FirstEntry
FirstEntry = LastEntry
wend
End Sub |
Schwerwiegend allerdings war, bei meinem delEntry die übergabe per byref, das führte zu schweren Fehlern...
sollte aber nun wirklich funktionieren...
Hab mir inzwischen mal deine Pathfind-Routine angesehen... hab sie zwar nicht ganz überblicken können. Habe meine aber (bis jetzt) glaube auf dem selben Prinzip aufgebaut, das überraschend einfach ist 
http://www.freebasic-portal.de/porticula/mymazepregetpath-1608.html
_________________
|
|
| Nach oben |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007
Beiträge: 1839
Wohnort: [JN58JR]
|
| Verfasst am: 22.03.2013, 15:29 Titel: |
|
|
Naja.. prinzipiel ist es ja recht simpel.
Ziel = wertigkeit 0
nachbarpixel vom ziel = 1
nachbar vom nachbarpixel = 2
usw.
im endeffekt machst du nichts anderes als, je weiter du vom ziel weg kommst, desto gröser wird der wert in den pixeln.
vergleichbar mit einem https://lh6.googleusercontent.com/_MRd4TuQSEag/Tdu_5RXJR1I/AAAAAAAAB4w/9LYbqOymJAg/BrushAlpha.png
wobei weis 0 und schwarz N is.
dann kann man von jeder beliebigen position aus die entfernung anhand des wertes auf der position ermitteln, udn durch dem folgen von N nach 0, lässt sich der weg ermitteln.
PS: Clear: joar .. das hätte sich nur dann schiwerig ausgewirkt, wenn du eine leere liste hättest löschen wollen.
MfG
TPM
_________________
[ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ]
Zuletzt bearbeitet von ThePuppetMaster am 23.03.2013, 16:55, insgesamt einmal bearbeitet |
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 23.03.2013, 09:02 Titel: |
|
|
| ThePuppetMaster hat Folgendes geschrieben: | | PS: Clear: joar .. das hätte sich nur dann schiwerig ausgewirkt, wenn du eine leere liste hättest löschen wollen. |
Naja, das Problem hätte ja die If-Abfrage im inneren verhindert
Trotzdem ist Deine Variante wesentlich Eleganter und kürzer
| ThePuppetMaster hat Folgendes geschrieben: | Naja.. prinzipiel ist es ja recht simpel.
Ziel = wertigkeit 0
nachbarpixel vom ziel = 1
nachbar vom nachbarpixel = 2
usw. |
So in etwa hab ich das Prinzip auch übernommen, nur umgekehrt.. bei mir hat Start den Wert '1' und geht dann weiter bis zum Ziel bzw den Feld das am nächsten am angegebenen Ziel dran ist (Falls Ziel zB. eine Wand ist...)
So ist daraus eine recht überschaubare Funktion geworden...
EDIT: http://www.freebasic-portal.de/porticula/mymaze-pathfind-1611.html
| Code: |
Function tMaze.getPath(byval fromX as Integer, byval fromY as Integer, byval targetX as Integer, byval targetY as Integer) as Integer ptr
Dim PathMap as Integer ptr
Dim PathList as Integer ptr
Dim PathLength as Integer
Dim frompos as Integer = fromX+(fromY*MazeW)
Dim targetpos as Integer = targetX+(targetY*MazeW)
Dim mappos as Integer
Dim nearestpos as Integer
Dim distance as Double
Dim distanceL as Double = MazeW*MazeH
Dim as integer tX,tY
Dim fillList as tList
fillList.AddEntry(frompos)
If (frompos < 0) or (frompos > ((MazeW*MazeH)-1)) Then return 0
PathMap = NEW Integer[MazeW*MazeH]
While fillList.FirstEntry
mappos = fillList.FirstEntry -> EntryValue
fillList.DelEntry(fillList.FirstEntry)
PathMap[mappos] += 1 'Set PathCost
tX = mappos mod MazeW
tY = mappos \ MazeW
distance = Distance2(tX,tY,targetX,targetY)
If (distance < distanceL) Then
distanceL = distance
nearestpos = mappos
End If
If (mappos = targetpos) then exit while
If (tX > 0) andalso ( (MazeP[mappos-1] < MazeWall) and PathMap[mappos-1] = 0 ) Then fillList.AddEntry(mappos-1) : PathMap[mappos-1] = PathMap[mappos]
If (tY > 0) andalso ( (MazeP[mappos-MazeW] < MazeWall) and PathMap[mappos-MazeW] = 0 ) Then fillList.AddEntry(mappos-MazeW) : PathMap[mappos-MazeW] = PathMap[mappos]
If (tX < (MazeW-1)) andalso ( (MazeP[mappos+1] < MazeWall) and PathMap[mappos+1] = 0 ) Then fillList.AddEntry(mappos+1) : PathMap[mappos+1] = PathMap[mappos]
If (tY < (MazeH-1)) andalso ( (MazeP[mappos+MazeW] < MazeWall) and PathMap[mappos+MazeW] = 0 ) Then fillList.AddEntry(mappos+MazeW) : PathMap[mappos+MazeW] = PathMap[mappos]
Wend
PathLength = PathMap[nearestpos]
PathList = New Integer[PathLength+1]
PathList[0] = PathMap[nearestpos]
PathList[PathMap[nearestpos]] = nearestpos
Do
mappos = nearestpos
PathLength = PathMap[mappos]
PathList[PathLength] = mappos
If (PathLength = 1) Then Exit Do
tX = mappos mod MazeW : tY = mappos \ MazeW
If (tX > 0) andalso PathMap[mappos-1] = PathLength-1 Then nearestpos -= 1 : continue do
If (tY > 0) andalso PathMap[mappos-MazeW] = PathLength-1 Then nearestpos -= MazeW : continue do
If (tX < (MazeW-1)) andalso PathMap[mappos+1] = PathLength-1 Then nearestpos += 1 : continue do
If (tY < (MazeW-1)) andalso PathMap[mappos+MazeW] = PathLength-1 Then nearestpos += MazeW : continue do
exit do
Loop
fillList.DestroyList()
Delete[] PathMap
return PathList
End Function
|
_________________
|
|
| Nach oben |
|
|
|
|
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
|
|
FAQ
Suchen
Mitgliederliste
Benutzergruppen
Registrieren
Profil
Einloggen, um private Nachrichten zu lesen
Login
