Pathfinder-ongelma

[Jonez]

Tarkoituksena olisi tehdä pathfinder-funktio, jonka ainoa tehtävä on kertoa pääseekö pisteestä A pisteeseen B. Mitään nopeinta reittiä ei tarvitse tietää.

Pathfinder toimii teoriassa näin:
1. Etsitään vapaita paloja joka suunnalta (suuntia on 4).
2. Jos löydetään vapaa pala, siirrytään siihen välittömästi. Vapaa pala on pala johon ei ole esteitä, eikä siinä olla käyty vielä kertaakaan.
3. Asetetaan tämän uuden palan dataan tieto edellisen palan koordinaateista. Sen lisäksi laitetaan palaan tieto, että sitä on jo käytetty.
4. Hypätään kohtaan 1.
5. Kun tullaan umpikujaan (vapaita reittejä ei enää ole), palataan edelliseen palaan käyttäen tiedossa olevia koordinaatteja. Hypätään kohtaan 1.
6. Jos löydetään tavoite-koordinaatit, palautetaan yksinkertaisesti True.
7. Logiikan mukaan pathfinderin pitäisi käydä kaikki haarautumat ja palata lopulta ekaan palaan. Jos ollaan ensimmäisessä palassa, eikä vapaita paloja ympärillä ole, ei tavoitetta löydetty. Palautetaan False.

Tällä hetkellä pathfinder ei jostain syystä löydä kaikkia vapaita paloja.

Code: Select all

SCREEN 1024, 768

Dim dLauta( 7, 7, 1 )
Dim dMove( 7, 7, 2 )

plX = 1
plY = 1

Repeat

    For x = 1 To 7
        For y = 1 To 7
            Color cbWhite
            Box x * 64, y * 64, 64, 64, 0
            
            Select dLauta( x, y, 0 )
                Case 1
                    Line x * 64 + 32, y * 64, x * 64 + 32, ( y + 1 ) * 64
                Case 2
                    Line x * 64, y * 64 + 32, ( x + 1 ) * 64, y * 64 + 32
                Case 3
                    Line x * 64 + 32, y * 64, x * 64 + 32, y * 64 + 32
                    Line x * 64 + 32, y * 64 + 32, ( x + 1 ) * 64, y * 64 + 32
                Case 4
                    Line x * 64 + 32, y * 64 + 32, x * 64 + 32, ( y + 1 ) * 64
                    Line x * 64 + 32, y * 64 + 32, ( x + 1 ) * 64, y * 64 + 32
                Case 5
                    Line x * 64 + 32, y * 64 + 32, x * 64 + 32, ( y + 1 ) * 64
                    Line x * 64, y * 64 + 32, x * 64 + 32, y * 64 + 32
                Case 6
                    Line x * 64 + 32, y * 64, x * 64 + 32, y * 64 + 32
                    Line x * 64, y * 64 + 32, x * 64 + 32, y * 64 + 32
                Case 7
                    Line x * 64 + 32, y * 64, x * 64 + 32, ( y + 1 ) * 64
                    Line x * 64 + 32, y * 64 + 32, ( x + 1 ) * 64, y * 64 + 32
                Case 8
                    Line x * 64 + 32, y * 64 + 32, x * 64 + 32, ( y + 1 ) * 64
                    Line x * 64, y * 64 + 32, ( x + 1 ) * 64, y * 64 + 32
                Case 9
                    Line x * 64 + 32, y * 64, x * 64 + 32, ( y + 1 ) * 64
                    Line x * 64, y * 64 + 32, x * 64 + 32, y * 64 + 32                 
                 Case 10
                    Line x * 64 + 32, y * 64, x * 64 + 32, y * 64 + 32
                    Line x * 64, y * 64 + 32, ( x + 1 ) * 64, y * 64 + 32
            End Select
            Text x * 64, y * 64, dLauta( x, y, 0 )
            
            Color cbRed
            
            If dMove( x, y, 0 ) = 1 Then
                Circle x * 64 + 32, y * 64 + 32, 10 
            EndIf
            
        Next y
    Next x
    startX = 64
    startY = 64
    
    _iX = ( MouseX() - startX ) / 64 + 1
    _iY = ( MouseY() - startY ) / 64 + 1    

    If MouseX() < startX Then _iX = 0
    If MouseY() < startY Then _iY = 0

    If MouseHit( 1 ) Then
        If InMap( _iX, _iY ) Then
            plX = _iX
            plY = _iY
        EndIf
    EndIf
    
    Circle plX * 64 + 32, plY * 64 + 32, 20

    If FindRoute( plX, plY, _iX, _iY ) = False Then
        Color cbRed
    Else
        Color cbWhite
    EndIf
    
    Box MouseX() - 10, MouseY() - 10, 20, 20, 0
    Color cbWhite


    
    If KeyHit( CbKeyReturn ) Then
        For x = 1 To 7
            For y = 1 To 7
                dLauta( x, y, 0 ) = Rand( 1, 10 )
            Next y
        Next x
    EndIf
    
    Text 20, 0, _iX + " " + _iY
    Text 20, 13, "Hiiri1 siirtää aloitusta..."
    Text 20, 26, "Enter luo mapin."
    DrawScreen
Forever

Function FindRoute( _startX, _startY, _endX, _endY )
    //nollataan alue
    For x = 1 To 7
        For y = 1 To 7
            For i = 0 To 2
                dMove( x, y, i ) = 0 
            Next i
        Next y
    Next x
    
    If InMap( _endX, _endY ) = False Then Return False
    If _startX = _endX And _startY = _endY Then Return True
    
    _seekX = _startX
    _seekY = _startY
 
    dMove( _startX, _startY, 0 ) = 1 
    dMove( _startX, _startY, 1 ) = _startX
    dMove( _startX, _startY, 2 ) = _startY
    While True
        bExit = False
        For x = -1 To 1
            For y = -1 To 1
                If x = 0 Xor y = 0 Then
                    
                    If InMap( _seekX + x, _seekY + y ) Then
                        //jos alue on vapaa...
                        If CheckCollision( _seekX, _seekY, _seekX + x, _seekY + y ) Then

                            //jos löydettiin tavoite, palautetaan True
                            If _seekX + x = _endX And _seekY + y = _endY Then
                                Return True
                            EndIf
                            
                            //jos palassa ei vielä olla käyty...
                            If dMove( _seekX + x, _seekY + y, 0 ) = 0 Then
                            
                                Color cbRed
                                Circle ( _seekX + x ) * 64 + 32, ( _seekY + y ) * 64 + 32, 10
                                //laitetaan muistiin että nykyinen pala on jo "käytetty"
                                dMove( _seekX + x, _seekY + y, 0 ) = 1
                                dMove( _seekX + x, _seekY + y, 0 ) = 1
                                
                                //asetetaan siirryttävään palaan tieto, mistä palasta siihen siirryttiin
                                dMove( _seekX + x, _seekY + y, 1 ) = _seekX
                                dMove( _seekX + x, _seekY + y, 2 ) = _seekY
                                
                                //siirrytään palaan...
                                _seekX = _seekX + x
                                _seekY = _seekY + y

                                bExit = True
                                Exit
                            EndIf
                        EndIf
                        
                    EndIf
                EndIf
            Next y
            If bExit = True Then Exit
        Next x

        //jos ei löydetty yhtäkään palaa mihin voi liikkua...
        If bExit = False Then
            //tavoitetta ei löydetty, palautetaan false
            If _seekX = _startX And _seekY = _startY Then
                Return False
            EndIf

            //asetetaan muistiin että pala on jo käytetty.
            dMove( _seekX, _seekY, 0 ) = 1
            
            //jos vielä ei olla alkupalassa, niin siirrytään edelliseen palaan...
            _seekX = dMove( _seekX, _seekY, 1 )
            _seekY = dMove( _seekX, _seekY, 2 )
        EndIf  
    Wend
End Function


Function CheckCollision( _x1, _y1, _x2, _y2 )

    _data = dLauta( _x1, _y1, 0 )
    Select _data
        Case 1
            _ylä = True
            _ala = True
        Case 2
            _vasen = True
            _oikea = True        
        Case 3
            _ylä = True
            _oikea = True        
        Case 4
            _ala= True
            _oikea = True
        Case 5
            _vasen = True
            _ala = True
        Case 6
            _ylä = True
            _vasen = True
        Case 7
            _ylä = True
            _ala = True
            _oikea = True    
        Case 8
            _vasen = True
            _oikea = True
            _ala = True
        Case 9
            _ylä = True
            _vasen = True
            _ala = True
        Case 10
            _vasen= True
            _ylä = True
            _oikea = True
    End Select

    _data = dLauta( _x2, _y2, 0 )
    Select _data
        Case 1
            _ylä2 = True
            _ala2 = True
        Case 2
            _vasen2 = True
            _oikea2 = True        
        Case 3
            _ylä2 = True
            _oikea2 = True        
        Case 4
            _ala2= True
            _oikea2 = True
        Case 5
            _vasen2 = True
            _ala2 = True
        Case 6
            _ylä2 = True
            _vasen2 = True
        Case 7
            _ylä2 = True
            _ala2 = True
            _oikea2 = True    
        Case 8
            _vasen2 = True
            _oikea2 = True
            _ala2 = True
        Case 9
            _ylä2 = True
            _vasen2 = True
            _ala2 = True
        Case 10
            _vasen2 = True
            _ylä2 = True
            _oikea2 = True
    End Select

    If _x1 < _x2 Then
        If  _oikea And _vasen2 Then Return True
    ElseIf _x1 > _x2 Then
        If _vasen And _oikea2 Then Return True
    ElseIf _y1 < _y2 Then
        If _ala And _ylä2 Then Return True
    ElseIf _y1 > _y2 Then
        If _ylä And _ala2 Then Return True
    EndIf
    
    Return False
End Function

Function InMap( _x, _y )
    If _x > 0 And _x < 8 And _y > 0 And _y < 8 Then Return True
End Function

[JATothrim]

En ole aivan varma etsitkö tämmöistä. Funktio tarkistaa onko reitti A:sta B:en olemassa. taulukon kokoa voi muuttaa.

Sotkuinen funktio ja esimerkki:

Code: Select all

Dim Kenttä(10,10)
Dim Käyty(10,10) As Byte
Type cord
	Field x
	Field y
EndType

Function MapThrought(x,y,x2,y2)
	//Aloitus kohta
	For i=1 To 10
	For j=1 To 10
		Käyty(j,i)=0
	Next j
	Next i
	pos.cord=New(cord)
	pos\x=x
	pos\y=y
	Käyty(x,y)=1
	For ipos.cord=Each cord
		//jos node saavutti koordinaatit, reitti ON mahdollinen.
		If ipos\x=x2 And ipos\y=y2
			//poistetaan mahdollinen Data.
			For ipos2.cord=Each cord
				Delete ipos2
			Next ipos2
			Return 1
		EndIf
		//Lisätään vapaaseen paikkaan node
		If ipos\x>1
			If Kenttä(ipos\x-1,ipos\y)=0 And Käyty(ipos\x-1,ipos\y)=0
				pos.cord=New(cord)
				pos\x=ipos\x-1
				pos\y=ipos\y
				Käyty(ipos\x-1,ipos\y)=1
			EndIf
		EndIf
		If ipos\x<10
			If Kenttä(ipos\x+1,ipos\y)=0 And Käyty(ipos\x+1,ipos\y)=0
				pos.cord=New(cord)
				pos\x=ipos\x+1
				pos\y=ipos\y
				Käyty(ipos\x+1,ipos\y)=1
			EndIf
		EndIf
		If ipos\y>1
			If Kenttä(ipos\x,ipos\y-1)=0 And Käyty(ipos\x,ipos\y-1)=0
				pos.cord=New(cord)
				pos\x=ipos\x
				pos\y=ipos\y-1
				Käyty(ipos\x,ipos\y-1)=1
			EndIf
		EndIf
		If ipos\y<10
			If Kenttä(ipos\x,ipos\y+1)=0 And Käyty(ipos\x,ipos\y+1)=0
				pos.cord=New(cord)
				pos\x=ipos\x
				pos\y=ipos\y+1
				Käyty(ipos\x,ipos\y+1)=1
			EndIf
		EndIf
		Delete ipos
	Next ipos
	//loppu pistettä ei saavutettu.
	Return 0
EndFunction

SCREEN 800,600
Dim txt(1) As String
txt(0)="Reittiä ei ole"
txt(1)="Reitti mahdollinen"
lx=2
ly=5
ex=9
ey=5
Repeat
	mx=MouseX()
	my=MouseY()

	cx=(mx/32)
	cy=(my/32)
	If MouseHit(1) Then Kenttä(cx,cy)=Kenttä(cx,cy) Xor 1
	If KeyHit(cbkey1) Then lx=cx:ly=cy
	If KeyHit(cbkey2) Then ex=cx:ey=cy
	
	For y=1 To 10
		For x=1 To 10
			If Kenttä(x,y)=0
				Color cbdark
				Box x*32,y*32,33,33,0
			Else
				Color cbred
				Box x*32,y*32,33,33
			EndIf
		Next x
	Next y
	
	Color Rand(100,255),Rand(100,255),Rand(100,255)
	Box cx*32,cy*32,32,32,0
	
	Text lx*32,ly*32+3,"#L#"
	Text ex*32,ey*32+3,"#M#"
	Text 0,0,txt(MapThrought(lx,ly,ex,ey))
	
	DrawScreen
Forever

[Jonez]

Kyllä toi sun funktio käy ihan hyvin, mutta haluaisin välttämättä saada tietää että mikä tossa mun funktiossa bugaa, ihan mielenkiinnosta ja oppimismielessä.

Ongelmahan on siis se, että palatessaan umpikujasta ohjelma ei aina löydä uutta, käyttämätöntä reittiä jos samasta palasta pääsee palan "palautus-koordinaatteihin", eli palaan mistä alunperin tultiin ja mistä pääsee aloitukseen. En voi käsittää miksi näin on, koska ihan selvästi ohjelma käy kaikki mahdolliset, uudet reitit _ensin_ läpi, ja seuraa niitä _heti_. Sillä ei ole mitään syytä mennä väärälle reitille. Ainoastaan siitä syystä se voi mennä jo käytetylle reitille, jos ohjelma luulee ko. reittiä käyttämättömäksi. Jälleen kerran, tämä ei tietääkseni ole mahdollista.

Olen näköjään pistänyt koodiin kaksi kertaa putkeen:
dMove( _seekX + x, _seekY + y, 0 ) = 1

Todennäköisesti mun piti silloin laittaa alempaan:
dMove( _seekX, _seekY, 0 ) = 1

Vaikka eihän toi mitenkään vaikuta ohjelman toimintaan. Totta puhuen olen kokeillut muuttaa pieniä kohtia funktiossa ihan randomilla jos se yhtäkkiä rupeaisikin toimimaan, kun en mitenkään onnistu näkemään aukkoa itse logiikassa.

Edit. Sain toimimaan. Vika oli siinä, kun siirryttiin edelliseen palaan: ensin _seekX sai uuden arvon käyttäen hyväkseen nykyistä _seekX- ja _seekY-arvoa, jonka jälkeen _seekY sai uuden arvon käyttäen vanhaa (ja oikeaa) _seekY-arvoa, sekä uutta ja väärää _seekX-arvoa.

[Pie2]

Joskus tein tämmösen joka käyttää A*-menetelmää. Koodi on suoraan sanottuna hirveää, koska ko. koodi oli pelkkä luonnoskoodaus.
Ehkä tästä on hyötyä jollekulle, ehkä ei.
Jos haluaa koodin huomaavan myös diagonaaliset reitit kannattaa muuttaa rivin 113 "step 90" -> "step 45"

Code: Select all

SetWindow "pathfinderi"
//KOODI ON SIISTIMÄTÖNTÄ joten sitä ei kannata lukea ;]


Dim map(10,10) As Byte
Dim list(10*10) As String

Dim map_parentx(10,10) As integer
Dim map_parenty(10,10) As integer

Global list_a
list_a=0
Dim dist(10,10) As integer
Dim map_d(10,10) As Byte

Dim path(10,10)
//ALKU
sx=3
sy=3
//LOPPU
ex=9
ey=9
////////////////////
start:
list_a=0
ReDim map_parentx(10,10)
ReDim map_parenty(10,10)
ReDim list(10*10)
ReDim dist(10,10)
ReDim path(10,10)
ReDim map_d(10,10)
Repeat
    //HIIRI
    For y=0 To 10
        For x=0 To 10
            If MouseDown(1) Then map(MouseX()/10,MouseY()/10)=1
            If MouseDown(2) Then map(MouseX()/10,MouseY()/10)=0
        Next x
    Next y

    //PIIRRETÄÄN
    For y=0 To 10
        For x=0 To 10
            If map(x,y)=0 Then Color 255,255,255 Else Color 80,80,80
            Box x*10,y*10,10,10
        Next x
    Next y
    //MAALI & ALKU
    Color 0,255,0
    Box sx*10,sy*10,10,10
    //maali
    Color 0,0,255
    Box ex*10,ey*10,10,10
    //HUD
    Color 255,255,255
    Text 110,0,"Paina ENTTERIÄ kun olet piirtänyt..."



    DrawScreen
Until KeyHit(28)
////////////////////




ad(sx,sy)
/////////////////
//käyttäjän ajatusten selventämiseksi piirretään kerran homma
For y=0 To 10
    For x=0 To 10
        If map(x,y)=0 Then Color 255,255,255 Else Color 80,80,80
        Box x*10,y*10,10,10
    Next x
Next y
//MAALI & ALKU
Color 0,255,0
Box sx*10,sy*10,10,10
//maali
Color 0,0,255
Box ex*10,ey*10,10,10
DrawScreen
/////////////////
Repeat



    //PÄIVITETÄÄN
    //ETSITÄÄN F
    tmp_l=1000
    tmp_id=-1
    For i=0 To 100
        If list(i)<>"" Then
            x=Int(Left(list(i),InStr(list(i),":")-1))
            y=Int(Mid(list(i),InStr(list(i),":")+1))
            f=dist(x,y)+Distance(ex,ey,x,y)*10
            If f<tmp_l Then tmp_l=f:tmp_id=i
        EndIf
    Next i
    //ETSITÄÄN SEURAAVAT

    i=tmp_id
    If i<>-1 Then
    If list(i)<>""
        x=Int(Left(list(i),InStr(list(i),":")-1))
        y=Int(Mid(list(i),InStr(list(i),":")+1))

        map_d(x,y)=1
        //JOS LÖYTYI MAALI
        If x=ex And y=ey Then Goto omfglol1337

        //LÄHELLÄOLEVAT
        For k=0 To 315 Step 90'45
            nx=x+Int(Cos(k))
            ny=y-Int(Sin(k))
            If nx>=0 And ny>=0 And nx<=10  And ny<=10 Then
                If map(nx,ny)=0 And map_d(nx,ny)=0 Then
                    ad(nx,ny):map_d(nx,ny)=2
                    //DISTANCE
                    a=k/45-1
                    If (a/2)=(a/2.0) Then
                        dist(nx,ny)=dist(x,y)+14
                    Else
                        dist(nx,ny)=dist(x,y)+10
                    EndIf
                    map_parentx(nx,ny)=x
                    map_parenty(nx,ny)=y

                EndIf
            EndIf
        Next k

        //POISTETAAN LISTASTA
        list(i)=""
        list_a=list_a-1
    EndIf
    EndIf

    //JOS POLKUA EI LÖYTYNYT
    If list_a=0 Then MakeError "No path :("

Until EscapeKey()
////////SUBS/////////



omfglol1337:
//HAETAAN LOPULLINEN PATH
x=ex
y=ey
Repeat
    path(x,y)=1
    nx=map_parentx(x,y)
    ny=map_parenty(x,y)
    x=nx:y=ny
    If x=sx And y=sy Then Exit
Forever


//PIIRRETÄÄN TULOS
//POHJA
For y=0 To 10
    For x=0 To 10
        If map(x,y)=0 Then Color 255,255,255 Else Color 80,80,80
        Box x*10,y*10,10,10
        Color 255,0,0
        If path(x,y) Then box x*10,y*10,10,10
    Next x
Next y
//MAALI & ALKU
Color 0,255,0
Box sx*10,sy*10,10,10
//maali
Color 0,0,255
Box ex*10,ey*10,10,10
//HUD
Color 0,0,0
Text 0,0,"VALMIS"
Color 255,255,255
Text 110,0,"Paina jtn..."

DrawScreen
WaitKey
Goto start




///////FUNCTIONS//////////
Function ad(x,y)
s$=Str(x)+":"+Str(y)

//LISÄÄ
    For i=0 To 100
        If list(i)="" Then
            list(i)=s
            list_a=list_a+1
            Return 0
        EndIf
    Next i
EndFunction