|
|
Post by tsh73 on Dec 28, 2021 17:50:01 GMT
Or so I understood.
(
Reinventing a wheel is a time-honored procrastination method.
Probably I should sit down and understand Dijkstra's or A* algorithm instead.
But hey, it works so far.
)
Just run it a fiew times.
Commented and wrapped to a function for possible reuse, just wait for next "move the balls" game...
'wavefront algorhithm for maze solving.
'(?) https://en.wikipedia.org/wiki/Lee_algorithm
'tsh73 Dec 2021
'well, I understood it this way
global numC,numR 'rows and columns
numC=9:numR=9
'All arrays are (row, column), from 0
dim c$(numR,numC) 'maze borders (#)
dim a(numR,numC) 'for marks
dim dirFrom(numR,numC) 'for getting path
dim path(10,2) 'the path, to be redimmed as needed
dim dx(4), dy(4)
DATA 0,1, 1,0, 0,-1, -1,0
for i = 1 to 4
read dx, dy
dx(i)=dx:dy(i)=dy
next
'make smth
for i = 0 to numR-1
for j = 0 to numC-1
if rnd(0)<.3 then
c$(i,j)="#"
else
'leave empty
end if
next
next
'select start, fin
while 1
x=int(rnd(0)*numC)
y=int(rnd(0)*numC)
if c$(y,x)="" then exit while
wend
c$(y,x)="S"
startJ=x:startI=y
while 1
x=int(rnd(0)*numC)
y=int(rnd(0)*numC)
if c$(y,x)="" then exit while
wend
c$(y,x)="F"
endJ=x:endI=y
print "The mase"
gosub [show]
pathLen=waveFront(startI,startJ,endI,endJ)
if pathLen then
print "solved it, pathLen=";pathLen
print "wavefront"
gosub [showA]
print "The path, length is ";pathLen
redim a(numR,numC) 'clear a()
for k = 0 to pathLen '0-th is Start, last is Fin
print k, path(k, 1), path(k, 2)
a(path(k, 1), path(k, 2))=k
next
print "Path in a maze "
gosub [showA]
else
print "No way"
gosub [showA]
end if
[quit]
input "press Enter to quit";dummy$
end
[show]
for i = 0 to numR-1
for j = 0 to numC-1
if c$(i,j)="" then
print " ";
else
print " ";c$(i,j);
end if
next
print "|"
next
print "------------------*"
return
[showA]
for i = 0 to numR-1
for j = 0 to numC-1
if c$(i,j)="" then
print using("##",a(i,j));
else
print " ";c$(i,j);
end if
next
print "|"
next
print "------------------*"
return
function waveFront(startI,startJ,endI,endJ)
q$=startI;",";startJ;" " 'queue on a string - init
'print "Q_:";q$
redim a(numR,numC) 'should do before new run
a(startI,startJ)=1
while 1
if q$="" then exit function 'print "No way": gosub [showA]: goto [quit]
'pop from a queue
pos=instr(q$, " ")
curr$=left$(q$, pos-1)
q$=mid$(q$, pos+1)
'print "Q-:";q$
i=val(word$(curr$,1,","))
j=val(word$(curr$,2,","))
v=a(i,j)
'mark neighbours
for d = 1 to 4
ni=i+dy(d):nj=j+dx(d)
'print d, ni, nj', a(ni,nj), c$(ni,nj)
if ni>=0 and ni <numR and nj>=0 and nj <numC then
'if c$(ni,nj)="F" then
if ni=endI and nj=endJ then
a(ni,nj)=v+1
dirFrom(ni,nj)=d
found = 1
exit for
end if
if c$(ni,nj)<>"#" and a(ni,nj)=0 then
a(ni,nj)=v+1
dirFrom(ni,nj)=d
'add to queue
q$=q$;ni;",";nj;" "
'print "Q+:";q$
end if
end if
next
if found then exit while
wend
'next we'll need to get path from S to F...
'construct a path
pathLen=a(endI,endJ)-1
redim path(pathLen,2)
j=endJ:i=endI
'print i, j, a(i,j), dirFrom(i,j)
path(pathLen, 1)=i 'last is Fin, 0-th is Start
path(pathLen, 2)=j
for k = 1 to pathLen
d=dirFrom(i,j)
ni=i-dy(d):nj=j-dx(d) 'going back, hence '-'
path(pathLen-k, 1)=ni
path(pathLen-k, 2)=nj
'print k, ni, nj, dirFrom(ni,nj), a(ni,nj)
if a(ni, nj)=1 then exit for
i=ni:j=nj
next
waveFront=pathLen
end function
|
|
|
|
Post by tsh73 on Feb 27, 2022 19:11:58 GMT
I integrate my path finder into cassiope34 program
(set up under button F3)
And you know what?
Then maze is empty, A* wins - because it knows where to go first
BUT
on maze that appears on double clicking, with very few paths to try - waveFront wins (as being simpler I guess)!
nomainwin
global STARTX, STARTY, ENDX, ENDY, c, nc, type, dia, show, lo$', lf$, Closed.List$
c = 20 'dimension d'un cotй de case en pixels
nc = 31 'nombre de cases sur 1 cotй (c'est un carrй !)
' BackgroundColor$ = cl$
' ForegroundColor$ = "darkblue"
'''''''''''''''''''''Joseph''''''''''''''''''
Dim Path.Open.X(nc*nc) ' Open List
Dim Path.Open.Y(nc*nc)
Dim Path.Open.ParentX(nc*nc)
Dim Path.Open.ParentY(nc*nc)
Dim Path.Open.Cost(nc*nc)
Dim Path.Open.PCost(nc*nc)
Dim Path.Closed.X(nc*nc) ' Closed list
Dim Path.Closed.Y(nc*nc)
Dim Path.Closed.ParentX(nc*nc)
Dim Path.Closed.ParentY(nc*nc)
Global Path.Closed, Path.Open ' The number of items in
'''''''''''''''''''''''''''''''''''''''''''''
WindowWidth = nc*c + 14
if WindowWidth < 25*20+14 then WindowWidth = 25*20+14
WindowHeight = nc*c + 130
if WindowHeight < 25*20+130 then WindowHeight = 25*20+130
UpperLeftX=(DisplayWidth-WindowWidth)/4
UpperLeftY=(DisplayHeight-WindowHeight)/4
graphicbox #a.g, 2, 2, nc*c+6, nc*c+6
radiobutton #a.dep, "Start (green)", [start], [nothing], 30, WindowHeight-110, 90, 20
radiobutton #a.arr, "End (red)", [end], [nothing], 30, WindowHeight-80, 90, 20
radiobutton #a.mur, "Wall", [wall], [nothing], 125, WindowHeight-110, 40, 20
radiobutton #a.sol, "Del", [ground], [nothing], 125, WindowHeight-80, 40, 20
checkbox #a.dia, "Diagonal OK", [diagonal], [nodiag], 30, WindowHeight-52, 90, 20
checkbox #a.voir, "Show Work", [look], [noshow], 125, WindowHeight-52, 80, 20
button #a.bt, "F1", [search], UL, 180, WindowHeight-110, 40, 25
button #a.bt, "F2", [search2], UL, 220, WindowHeight-110, 40, 25
button #a.bt, "F3", [search3], UL, 260, WindowHeight-110, 40, 25
button #a.raz, "Reset", raz, UL, 215, WindowHeight-70
button #a.save, "Save", [save], UL, WindowWidth-60, WindowHeight-110
button #a.load, "Load", [load], UL, WindowWidth-60, WindowHeight-70
statictext #a.time, "Time :", 310, WindowHeight-110, 70, 15
statictext #a.ind, "Double-click on board to", 410, WindowHeight-110, 130, 15
statictext #a.case, "Dim...", 310, WindowHeight-90, 70, 15
statictext #a.ind2, "make a random MAZE !", 410, WindowHeight-90, 130, 15
statictext #a.iter, "Iteration :", 310, WindowHeight-70, 130, 15
statictext #a.len, "Path lenght :", 310, WindowHeight-50, 140, 15 'future
open "A* Shorter Path Finding" for dialog as #a ' graphics_nf_nsb as #a
#a "trapclose [quit]"
#a.mur "set" 'construction de murs par dйfaut du radiobutton.
type = 1 '1=eff 2=mur 3=pion vert 4=pion rouge
STARTX = int(nc/2)+1 'coord. pion vert = point de dйpart
STARTY = nc-1
ENDX = int(nc/2)+1 'coord. pion rouge = point d'arrivйe
ENDY = 2
dim cas(nc,nc)
#a.g "down"
#a.mur "set"
type = 2
call board
#a.g "when leftButtonMove LeftButtonClick"
#a.g "when leftButtonDown pawns"
' #a.g "when leftButtonDouble random"
#a.g "when leftButtonDouble MazeGenerate"
#a.g "when characterInput keyb"
[loopHere]
#a.g "setfocus"
scan
goto [loopHere]
wait
[ground]
type = 1 ' eff case = 0
wait
[wall]
type = 2 ' mur case = 1
wait
[start]
type = 3 ' pion Vert
wait
[end]
type = 4 ' pion Rouge
wait
[diagonal]
dia = 4
gosub [search]
wait
[nodiag]
dia = 0
gosub [search]
wait
[look]
show = 1
gosub [search]
wait
[noshow]
show = 0
gosub [search]
wait
[search]
call board
call pathfindOK 'handle$
wait
[search2]
call board
call Path.Find 'handle$
wait
[search3]
call board
call Path.Wave 'handle$
wait
[nothing]
wait
[save]
f$ = date$("mm/dd/yyyy")+time$()
filename$ = str$(nc)+"x"+str$(nc)+"_"+mid$(f$,4,2)+mid$(f$,1,2)+mid$(f$,7,4)+"_"+mid$(f$,11,2)+mid$(f$,14,2)+right$(f$,2)+".sav"
open filename$ for output as #sv 'sauvegarde la partie
#sv, nc
#sv, STARTX
#sv, STARTY
#sv, ENDX
#sv, ENDY
tabl$ = ""
for y = 1 to nc
for x = 1 to nc 'car les colonnes seront lu en commenзant par le bas !
tabl$ = tabl$ + str$(cas(x,y))
next
next
#sv, tabl$
close #sv
' notice "plateau sauvй"
wait
[load]
filedialog "Charge...", "*.sav", filename$
on error goto [padfich]
open filename$ for input as #tbl
line input #tbl, nca$
if val(nca$)<>nc then
close #tbl
notice nca$+"x"+nca$+" file incompatible..."
goto [padfich]
end if
nc = val(nca$)
line input #tbl, stx$ : STARTX = val(stx$)
line input #tbl, sty$ : STARTY = val(sty$)
line input #tbl, enx$ : ENDX = val(enx$)
line input #tbl, eny$ : ENDY = val(eny$)
line input #tbl, tabl$
for y = 1 to nc
for x = 1 to nc 'car les colonnes seront lu en commenзant par le bas !
cas(x,y) = val(mid$(tabl$,nc*(y-1)+x,1))
next
next
close #tbl
call board
call pathfindOK 'handle$
[padfich]
wait
sub keyb handle$, key$
notice key$
select case lower$(key$)
case "s"
notice "board saved"
case "r"
notice "board restored"
end select
end sub
sub random handle$, x, y 'gйnйrateur de labyrinthe !
call raz "#a.g"
nb = int((nc*nc*30)/100) '30% du nombre total de cases seront des murs...!
do
x=int(rnd(0)*nc)+1
y=int(rnd(0)*nc)+1
if cas(x,y) = 0 and (x <> STARTX or y <> STARTY) and (x <> ENDX or y <> ENDY) then
cas(x,y) = 1
call drawcell x, y, 1
i = i + 1
end if
loop until i = nb
call pathfindOK 'handle$
end sub
'''''''''''''''''''''''''''''''''''''''''''''''''Labyrinthe
sub MazeGenerate handle$, x, y
nRows = 0
nColumns = 0
Dim cell(1,1)
Dim cell.state(1,1)
Dim mazePath$(1,1)
totalCells = 0
visitedCells = 0
currentCell = 0
nextCell = 0
lastCell$ = ""
path$ = ""
d.X(1) = 0 : d.Y(1) = -1 'up
d.X(2) = 1 : d.Y(2) = 0 'right
d.X(3) = 0 : d.Y(3) = 1 'down 'il est possible de prйvoir 4 directions suplйmentaires si les diagonales sont admises...
d.X(4) = -1 : d.Y(4) = 0 'left
call raz handle$
for y = 1 to nc
for x = 1 to nc
cas(x,y) = 1
if x mod 2 = 0 and y mod 2 = 0 and x < nc and y < nc then cas(x,y) = 0
call drawcell x, y, cas(x,y)
next
next
nRows = int(nc/2)
nColumns = int(nc/2)
Redim cell.state(nRows+1,nColumns+1)
Redim cell(nRows+1, nColumns+1)
For row = 1 to nRows
For column = 1 to nColumns
cell(row,column) = (100*row + column) * -1
Next
Next
cell(nRows,1) = Abs(cell(nRows,1))
currentCell = cell(nRows,1)
totalCells = nRows*nColumns
visitedCells = 1
nextCell = 1
While visitedCells < totalCells
nextCell = nextCell(currentCell)
select case
case nextCell > 0
visitedCells = visitedCells + 1
currentCell = nextCell
currentCell$ = currentCell$(currentCell)
path$ = path$;"-";currentCell$
case nextCell = 0
path$ = Left$(path$,Len(path$)-7)
lastCell$ = Right$(path$,6)
currentCell = Val(Left$(lastCell$,3))*100 + Val(Right$(lastCell$,3))
End select
Wend
cas(STARTX,STARTY) = 0
cas(ENDX,ENDY) = 0
call board
call pathfindOK 'handle$
end sub
Function nextCell(currentCell)
nC = 0
nC$ = ""
rC = Abs(Int(currentCell/100))
cC = Abs(rC*100 - currentCell)
If cell(rC-1,cC) < 0 Then
nC = nC + 1
nC$ = nC$;Str$(Abs(cell(rC-1,cC)));" "
End If
If cell(rC,cC+1) < 0 Then
nC = nC + 1
nC$ = nC$;Str$(Abs(cell(rC,cC+1)));" "
End If
If cell(rC+1,cC) < 0 Then
nC = nC + 1
nC$ = nC$;Str$(Abs(cell(rC+1,cC)));" "
End If
If cell(rC,cC-1) < 0 Then
nC = nC + 1
nC$ = nC$;Str$(Abs(cell(rC,cC-1)));" "
End If
If nC = 0 Then
nextCell$ = ""
Else
rndPath = Int(Rnd(1)*nC)+1
nextCell$ = Word$(nC$, rndPath)
End If
nextCell = Val(nextCell$)
If nextCell = 0 Then
path = 0
Else
rN = Int(nextCell/100)
cN = nextCell - rN*100
If rC - rN = 1 Then path = 1
If cN - cC = 1 Then path = 2
If rN - rC = 1 Then path = 3
If cC - cN = 1 Then path = 4
End If
cell(rN,cN) = Abs(cell(rN,cN))
' call pause 1
Select Case path
Case 1 'North
cas(cC*2+d.X(path),rC*2+d.Y(path))=0
call drawcell cC*2+d.X(path), rC*2+d.Y(path), 0
' cell.state(rC,cC) = path
Case 2 'East
cas(cC*2+d.X(path),rC*2+d.Y(path))=0
call drawcell cC*2+d.X(path), rC*2+d.Y(path), 0
' cell.state(rC,cC) = path
Case 3 'South
cas(cC*2+d.X(path),rC*2+d.Y(path))=0
call drawcell cC*2+d.X(path), rC*2+d.Y(path), 0
' cell.state(rC,cC) = path
Case 4 'West
cas(cC*2+d.X(path),rC*2+d.Y(path))=0
call drawcell cC*2+d.X(path), rC*2+d.Y(path), 0
' cell.state(rC,cC) = path
End Select
End Function
Function currentCell$(currentCell)
r = Int(currentCell/100)
r$ = Str$(r)
While Len(r$) < 3
r$ = "0";r$
Wend
cc = currentCell - r*100
c$ = Str$(cc)
While Len(c$) < 3
c$ = "0";c$
Wend
currentCell$ = r$;c$
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''FIN Labyrinthe
sub LeftButtonClick handle$, MouseX, MouseY
if type = 1 or type = 2 then
mx = int(MouseX / c)+1
my = int(MouseY / c)+1
'print mx;" / ";my
#a.case, "...... ";mx;" / ";my;" type= ";type
if mx>1 and mx<nc and my>1 and my<nc and (mx<>STARTX or my<>STARTY) and (mx<>ENDX or my<>ENDY) then
cas(mx,my) = type-1
call drawcell mx, my, cas(mx,my)
end if
end if
end sub
sub pawns handle$, MouseX, MouseY
if type = 3 or type = 4 then 'pion Vert=dйpart, rouge=arrivйe
nouvX = int((MouseX) / c)+1
nouvY = int((MouseY) / c)+1
call drawpawn type, nouvX, nouvY
call board
call pathfindOK 'handle$
end if
end sub
sub board 'start board nc x nc with edges = 1 and update of cas(x,y)
#a.case, "Dim. : ";nc;" x ";nc
#a.g "color blue"
for i = 0 to nc
#a.g "place 1 ";i*c;"; goto ";nc*c;" ";i*c
next
for i = 0 to nc
#a.g "place ";i*c;" 1; goto ";i*c;" ";nc*c
next
y=1
for i = 1 to nc*nc
x=x+1
if x = 1 or x = nc then cas(x,y) = 1 'les bords = 1
if y = 1 or y = nc then cas(x,y) = 1
call drawcell x, y, cas(x,y)
if x>nc-1 then
x=0
y=y+1
end if
next
call drawpawn 3, STARTX, STARTY
call drawpawn 4, ENDX, ENDY
#a.g "Flush"
#a.g "Discard"
end sub
sub raz handle$ 'reset the board
redim cas(nc,nc)
y=1
for i = 1 to nc*nc
x=x+1
' cas(x,y) = 0
if x = 1 or x = nc then cas(x,y) = 1 'les bords = 1
if y = 1 or y = nc then cas(x,y) = 1
call drawcell x, y, cas(x,y)
if x>nc-1 then
x=0
y=y+1
end if
next
call drawpawn 3, STARTX, STARTY
call drawpawn 4, ENDX, ENDY
#a.g "Flush"
#a.g "Discard"
end sub
sub drawpawn p, nx, ny 'mise а jour et positionnement des pions
if cas(nx,ny) = 1 then exit sub
xx = STARTX 'pion vert
yy = STARTY
if p = 4 then 'pion rouge
xx = ENDX
yy = ENDY
#a.g "color red; backcolor red"
end if
#a.g "color white"
#a.g "backcolor white"
#a.g "place ";(xx-1)*c+2;" ";(yy-1)*c+2 'efface la case sur laquelle il йtait.
#a.g "boxfilled ";xx*c-1;" ";yy*c-1
select case p
case 3 'pion rouge
STARTX = nx 'pion vert
STARTY = ny
#a.g "color green; backcolor green" 'pion vert
case 4 'pion rouge
ENDX = nx
ENDY = ny
#a.g "color red; backcolor red" 'pion rouge
end select
#a.g "place ";(nx-1)*c+(c/2);" ";(ny-1)*c+(c/2)
#a.g "circlefilled 8"
end sub
sub drawcell xx, yy, v
#a.g "color white"
#a.g "backcolor white"
if v then #a.g "backcolor blue"
#a.g "place ";(xx-1)*c+2;" ";(yy-1)*c+2
#a.g "boxfilled ";xx*c-1;" ";yy*c-1
' option d'affichage valeur des cases...
' #a.g "color lightgray"
' #a.g "place ";(xx-1)*c+c/3;" ";(yy-1)*c+2*(c/3)+2
' #a.g "|";v
end sub
'************************************ DEBUT de la RECHERCHE du PLUS COURT CHEMIN ***************************************
sub pathfindOK 'handle$
'dim dirX(8)
'dim dirY(8)
dirX(1) = 0 : dirY(1) = -1 'up
dirX(2) = 1 : dirY(2) = 0 'right
dirX(3) = -1 : dirY(3) = 0 'left
dirX(4) = 0 : dirY(4) = 1 'down 'il est possible de prйvoir 4 directions suplйmentaires si les diagonales sont admises...
dirX(5) = -1 : dirY(5) = -1 'up,left
dirX(6) = 1 : dirY(6) = -1 'up,right
dirX(7) = -1 : dirY(7) = 1 'down,left 'les diagonales...
dirX(8) = 1 : dirY(8) = 1 'down,right
xc = STARTX 'case courante
yc = STARTY
ppp = 0 'distance pour arriver lа du parent... en l'occurance 0 puisque c'est la case de dйpart !
'format des listes = "_XXYYxxyypppCCC_XXYYxxyypppCCC_XXYYxxyypppCCC_XXYYxxyypppCCC" etc... une case = 15 caractиres.
' XXYY = coord. de la case
' xxyy = coord. de son parent (la case d'oщ elle vient)
' ppp = coыt de ce parent pour venir jusqu'ici dans le chemin. (cpv)
' CCC = coыt de la case = ppp + 1 + distance de la case а l'arrivйe а vol d'oiseau...
' la case son parent ppp son coыt (sur 3 chiffres)
lf$ = "_"+right$(str$(100+STARTX),2)+right$(str$(100+STARTY),2)+right$(str$(100+STARTX),2)+right$(str$(100+STARTY),2)'+"000"+right$(str$(1000+cost(cpv,STARTX,STARTY)),3) 'liste fermйe
lo$ = "" 'liste ouverte
td = time$("ms")
DO
'check all 4 (or 8) available directions
for i = 1 to 4 + dia 'ou 8 si les diagonales sont admises...
nextX = xc + dirX(i) 'coordonnйe de la case voisine dans la direction i
nextY = yc + dirY(i)
if cas(nextX, nextY) = 0 then ' if not a wall
' ccc = cost(ppp,nextX,nextY) 'Calcul du Coыt de cette case voisine.
ccc = ppp + abs(ENDY-nextY) + abs(ENDX-nextX) 'Calcul du Coыt de cette case voisine.
ct$ = "_"+right$(str$(100+nextX),2)+right$(str$(100+nextY),2) 'case а rechercher...
if nextY = ENDY and nextX = ENDX then 'arrivйe... 'and nextX = ENDX si nйcessitй d'une arrivйe sur ENDX,ENDY prйcisйment.
lf$ = lf$ + ct$ +right$(str$(100+xc),2)+right$(str$(100+yc),2)'+right$(str$(1000+ppp),3)+right$(str$(1000+ccc),3) 'liste fermйe
success = 1
goto [getout]
else
if instr(lf$,ct$) = 0 then 'si la case n'est PAS dans la liste fermйe ...
slo = instr(lo$, ct$) 'on la cherche dans la Liste Ouverte LO$
if slo = 0 then 'si la case n'est pas dans la liste ouverte : on l'y met et c'est tout...
lo$ = lo$ + ct$ +right$(str$(100+xc),2)+right$(str$(100+yc),2)+right$(str$(1000+ppp),3)+right$(str$(1000+ccc),3) 'liste ouverte
if show then #a.g "backcolor darkgray; color darkgray; place ";(nextX-1)*c+(c/2);" ";(nextY-1)*c+(c/2);"; circlefilled 4"
else 'si elle y est : comparer les 2 coыts
cclo = val(mid$(lo$, slo + 12, 3)) ' coыt de cette case dйjа prйsente dans lo$
if ccc < cclo then 'si le coыt actuel est infйrieur а celui de cette case trouvйe dans lo$ :
'mise а jour des donnйes de cette case dans la liste ouverte : " parent ppp et coыt"
lt$ = left$(lo$,slo+4) 'partie gauche de lo$ y compris les XXYY de la case а mettre а jour
lt$ = lt$ + right$(str$(100+xc),2) + right$(str$(100+yc),2) + right$(str$(1000+ppp),3) + right$(str$(1000+ccc),3) 'mise а jour du parent + cout
lo$ = lt$ + right$(lo$,len(lo$)-len(lt$)) ' reconstruction de lo$
end if
end if
end if
end if
end if
next i
nclo = len(lo$)/15 'nbre total de cases dans lo$ (liste ouverte) (rappel: 1 case = 15 caractиres)
select case nclo
case 0 'si liste ouverte vide = pas de solution... on arrкte.
goto [getout]
case 1 's'il n'y a qu'une case dans lo$ alors c'est celle lа qui est sйlectionnйe bien sыr...!
ncppc = 1
case else 'localise dans lo$ le n° de la case qui a le plus petit coыt... = ncppc
mc = val(right$(lo$,3)) 'coыt rйfйrence = celui de la DERNIERE case enregistrйe dans lo$
ncppc = nclo
for n = nclo to 1 step -1 'puis on remonte case par case dans lo$ en partant de la fin...
mc2 = val(mid$(lo$, n*15-2, 3)) 'coыt de la case prйcйdente dans lo$
if mc2 < mc then 'cout infйrieur trouvй...
mc = mc2
ncppc = n 'ncppc = localisation (base 15) dans lo$ de la case qui a le plus petit cout.
end if
next
end select
' maintenant retirer de lo$ la case qui a le plus petit coыt (dйterminйe ci-dessus)
' la mettre dans la liste fermйe.
' en faire la case courante.
lt$ = mid$(lo$,(ncppc-1)*15+1,15) ' la case choisie dans lo$ est mise dans une chaine temporaire.
xc = val(mid$(lt$,2,2)) 'devient la nouvelle case courante, (et donc le nouveau parent...)
yc = val(mid$(lt$,4,2))
ppp = val(mid$(lt$,10,3)) + 1 'nouveau coыt pour venir jusqu'ici (dans le chemin)
'print "Liste Ouverte = ";lo$
'print " Choix =";lt$
lf$ = lf$ + left$(lt$,9) 'ajoutйe а la liste fermйe (constitution du chemin)
'print "Liste Fermйe = ";lf$
'retrait de cette case de lo$ (liste ouverte) :
lt$ = left$(lo$,(ncppc-1)*15) 'partie gauche de lo$ avant la case choisie
rst = nclo - (len(lt$)/15+1)
lo$ = lt$ + right$(lo$,rst*15) 'reconstitution de la Liste Ouverte
'print
'print "Liste Ouverte = ";lo$
'print
'print
iterations = iterations + 1
LOOP UNTIL success
[getout] ' FIN de la RECHERCHE du PLUS COURT CHEMIN
t = time$("ms") - td
#a.time, "Time : "; t; " ms."
#a.iter, "len( lo$ ) : ";len(lo$)
' #a.len, "Path lenght : --"
'pathLenght = val(right$(lf$,3)) + 1 'dernier coыt de la derniиre case enregistrйe dans la liste fermйe lf$
pathLenght = (len(lf$)/9)-2
if success then
' call showpath
'print
'print "Shortest path found in "; iterations; " iterations."
'print "Longueur du chemin "; pathLenght; " cases - Trouvй en "; t; " ms."
'print
'variante plus propre de lecture de lf$ de Joseph...
l = 0
#a.g "down; size 1; backcolor red; color red"
i = instr(lf$,"_"+right$(str$(100+nextX),2)+right$(str$(100+nextY),2))
while i > 1
x = val(mid$(lf$,i+5,2))
y = val(mid$(lf$,i+7,2))
#a.g "place ";(x-1)*c+(c/2);" ";(y-1)*c+(c/2);"; circlefilled 4"
l = l + 1
i = instr(lf$,"_"+right$(str$(100+x),2)+right$(str$(100+y),2))
Wend
#a.len, "Path lenght : ";l
#a.g "backcolor white"
#a.g "Flush"
#a.g "Discard"
else
#a.len, "Path lenght : impossible. (";pathLenght;")"
end if
end sub
function cost(cp,vx,vy) 'cout du parent pour venir par le chemin + distance de vy а ENDY.
cost = cp + abs(ENDY-vy) + abs(ENDX-vx) 'distance entre vy et ENDY (l'arrivйe)
end function
sub showpath
' en partant de l'arrivйe ... c.а.d. la derniиre case de la liste fermйe.
#a.g "down; size 1; backcolor red; color red"
n = len(lf$)/9
x = val(mid$(lf$,(n-1)*9+2,2)) 'x,y de la derniиre case de la liste fermйe
y = val(mid$(lf$,(n-1)*9+4,2))
#a.g "place ";(x-1)*c+(c/2);" ";(y-1)*c+(c/2);"; circlefilled 4"
do
x = val(mid$(lf$,(n-1)*9+6,2)) 'x,y du parent prйcйdent dans la liste fermйe
y = val(mid$(lf$,(n-1)*9+8,2))
#a.g "place ";(x-1)*c+(c/2);" ";(y-1)*c+(c/2);"; circlefilled 4"
'possible de constituer la chaine du chemin en enregistrant ici les x,y
' n$ = "_"+right$(str$(100+x),2)+right$(str$(100+y),2) 'recherche la "case" = au "parent" en remontant dans la liste fermйe
n$ = "_"+mid$(lf$,(n-1)*9+6,4) 'recherche la "case" = au "parent" en remontant dans la liste fermйe
n = ((instr(lf$,n$)-1)/9)+1
l = l + 1
' x = val(mid$(lf$,(n-1)*15+2,2))
' y = val(mid$(lf$,(n-1)*15+4,2))
' #a.g "place ";(x-1)*c+(c/2);" ";(y-1)*c+(c/2);"; circlefilled 4"
loop until n < 3
#a.len, "Path lenght : ";l - 1
#a.g "backcolor white"
#a.g "Flush"
#a.g "Discard"
end sub
'************************************************ FIN Recherche *********************************************
function rept$(c$,n) 'rйpйtition d'un caractиre dans un chaine.
for i = 1 to n
rept$ = rept$ + c$
next
end function
sub pause temp
t=time$("ms")
t2=t
while t2<t+temp
t2=time$("ms")
wend
end sub
''''''''''''''''''''Version de Joseph''''''''''''''''''''''''''
sub Path.Find 'handle$
' Returns 0 (false) if a path was not found.
' Otherwise the answer is the number of coordinates in answer$
' To get to the location.
' The coordinates placed in answer$ are like this:
' XX_YY XX_YY ... and so on.
' So you could get them by:
' cord1$ = Word$(answer$,1)
' cord1x = Val(Word$(cord1$,1,"_"))
' cord1y = Val(Word$(cord1$,2,"_"))
'Dim Dir.X(4)
'Dim Dir.Y(4)
Dir.X(1) = 0 : Dir.Y(1) = -1 ' Up
Dir.X(2) = 1 : Dir.Y(2) = 0 ' Right
Dir.X(3) = -1 : Dir.Y(3) = 0 ' Left
Dir.X(4) = 0 : Dir.Y(4) = 1 ' Down
Dir.X(5) = -1 : Dir.Y(5) = -1 'up,left
Dir.X(6) = 1 : Dir.Y(6) = -1 'up,right
Dir.X(7) = -1 : Dir.Y(7) = 1 'down,left 'les diagonales...
Dir.X(8) = 1 : Dir.Y(8) = 1 'down,right
' Start at the start location.
x = STARTX : y = STARTY
' Closed.List$ = ""
Path.Open = 0
Path.Closed = 0
' success = 0
' i = 0
td = time$("ms")
ppp = 0
' Put the starting location on the closed list:
' Call Path.ClosedPush STARTX, STARTY,0,0
Closed.List$ = Closed.List$ + "_"+right$(str$(100+STARTX),2)+right$(str$(100+STARTY),2)+right$(str$(100+0),2)+right$(str$(100+0),2)
Do
For i = 1 To 4 + dia
' Check all the directions:
nextX = x + Dir.X(i)
nextY = y + Dir.Y(i)
If cas(nextX,nextY) = 0 Then ' Square is open...so...
' Calculate the cost of the neighboring square:
cost = ppp + Abs(ENDX - nextX) + Abs(ENDY - nextY)
If nextX = ENDX And nextY = ENDY Then
' Arrived at destination
Closed.List$ = Closed.List$+"_"+right$(str$(100+nextX),2)+right$(str$(100+nextY),2)+right$(str$(100+x),2)+right$(str$(100+y),2)
success = 1
GoTo [GetOut]
Else
' Haven't arrived at our destination:
'If Not(Path.IsClosed(nextX, nextY)) Then
If instr(Closed.List$,"_"+right$(str$(100+nextX),2)+right$(str$(100+nextY),2))=0 Then
' Current square isn't on the closed list
isOpen = Path.IsOpen(nextX,nextY) ' If the box is in the open list, this is the array index to the box's values.
If Not(isOpen) Then
' Path isn't on the open list, so we push it in there
Call Path.OpenPush nextX,nextY,x,y,cost,ppp
' (x,y) is the parent location for the new open list item: (nextX,nextY)
if show then #a.g "backcolor darkgray; color darkgray; place ";(nextX-1)*c+(c/2);" ";(nextY-1)*c+(c/2);"; circlefilled 4"
Else
' Path is on the open list, so we compare costs.
If cost < Path.Open.Cost(isOpen) Then
' Current cost is below the cost of that box in the open list.
' So we update the parent and the cost?
Path.Open.ParentX(isOpen) = x
Path.Open.ParentY(isOpen) = y
Path.Open.PCost(isOpen) = ppp
Path.Open.Cost(isOpen) = cost
End If
End If
End If
End If
End If
Next i
Select Case Path.Open ' The number of cells in the open list...
Case 0
' Nothing left...
GoTo [GetOut]
Case 1
' The only one left? Then of course we'll take it!
selectedBox = 1
Case Else
' Locate the box that has the lowest value in the open list.
' Last box put on the list to reference against:
lastCost = Path.Open.Cost(Path.Open)
selectedBox = Path.Open
' ----------------------------------------------- '
For n = Path.Open To 1 Step -1 ' Look for it going backwards...
referenceCost = Path.Open.Cost(n)
If referenceCost < lastCost Then
lastCost = referenceCost
selectedBox = n ' Location of the box with the smallest cost.
End If
Next n
End Select
' Now let's take the box with the smallest cost and put it in the closed list.
' Becomes the new cell...and the new parent of other cells.
oldX = x : oldY = y
x = Path.Open.X(selectedBox)
y = Path.Open.Y(selectedBox)
ppp = Path.Open.PCost(selectedBox) + 1
Closed.List$ = Closed.List$ + "_"+right$(str$(100+x),2)+right$(str$(100+y),2)+right$(str$(100+Path.Open.ParentX(selectedBox)),2)+right$(str$(100+Path.Open.ParentY(selectedBox)),2)
' print len(Closed.List$)
' Call Path.ClosedPush x,y,Path.Open.ParentX(selectedBox),Path.Open.ParentY(selectedBox) ' Add it to the closed list
Call Path.OpenRemove selectedBox ' Remove it from the open list
Loop Until success
[GetOut]
t = time$("ms") - td
#a.time, "Time : "; t; " ms."
#a.iter, "len( CList$ ) : ";len(Closed.List$)
If success Then
' l = 0
#a.g "size 1; backcolor red; color red"
i = instr(Closed.List$,"_"+right$(str$(100+nextX),2)+right$(str$(100+nextY),2))
while i > 1
x = val(mid$(Closed.List$,i+5,2))
y = val(mid$(Closed.List$,i+7,2))
#a.g "place ";(x-1)*c+(c/2);" ";(y-1)*c+(c/2);"; circlefilled 4"
l = l + 1
i = instr(Closed.List$,"_"+right$(str$(100+x),2)+right$(str$(100+y),2))
Wend
#a.len, "Path lenght : ";l
#a.g "backcolor white"
#a.g "Flush"
#a.g "Discard"
else
#a.len, "Path lenght : impossible... "
End If
End Sub
Function Path.IsClosed(x,y)
' Returns a number greater than 0 if the box (x,y) is on the closed list.
' This number is the array index of the item on the closed list.
For i = 1 To Path.Closed
If Path.Closed.X(i) = x And Path.Closed.Y(i) = y Then
Path.IsClosed = i
Exit Function
End If
Next i
End Function
Sub Path.ClosedPush x,y,parentX,parentY
' Push the square (x,y) onto the closed list.
Path.Closed = Path.Closed + 1
Path.Closed.X(Path.Closed) = x
Path.Closed.Y(Path.Closed) = y
Path.Closed.ParentX(Path.Closed) = parentX
Path.Closed.ParentY(Path.Closed) = parentY
End Sub
Sub Path.OpenPush x,y,parentX,parentY,cost,ppp
' Pushes the square (x,y) with the (parentX,parentY) and (cost)
' onto the open list.
Path.Open = Path.Open + 1
Path.Open.X(Path.Open) = x
Path.Open.Y(Path.Open) = y
Path.Open.Cost(Path.Open) = cost
Path.Open.ParentX(Path.Open) = parentX
Path.Open.ParentY(Path.Open) = parentY
Path.Open.PCost(Path.Open) = ppp
End Sub
Sub Path.OpenRemove index
' Removes the item with the index 'index' from the open list.
If index = 0 Then Exit Sub
For i = index+1 To Path.Open
b = i - 1
Path.Open.X(b) = Path.Open.X(i)
Path.Open.Y(b) = Path.Open.Y(i)
Path.Open.ParentX(b) = Path.Open.ParentX(i)
Path.Open.ParentY(b) = Path.Open.ParentY(i)
Path.Open.Cost(b) = Path.Open.Cost(i)
Path.Open.PCost(b) = Path.Open.PCost(i)
Next i
o = Path.Open
Path.Open.X(o) = 0 : Path.Open.Y(o) = 0 : Path.Open.ParentX(o) = 0
Path.Open.ParentY(o) = 0 : Path.Open.Cost(o) = 0 : Path.Open.PCost(o) = 0
Path.Open = Path.Open - 1
End Sub
Function Path.IsOpen(x,y)
' Returns a number greater than 0 if the box (x,y) is on the open list.
' This number is the array index of the item on the open list.
For i = 1 To Path.Open
If Path.Open.X(i) = x And Path.Open.Y(i) = y Then
Path.IsOpen = i
Exit Function
End If
Next i
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''
[quit]
close #a
end
'======================================================
global numC,numR 'rows and columns
sub Path.Wave
numC=nc+1
numR=nc+1
'all arrays are roe, column that is y,x. 0-based.
dim c$(numR,numC) 'maze borders (#)
dim a(numR,numC) 'for marks
dim dirFrom(numR,numC) 'for getting path
dim path(10,2) 'the path, to be redimmed as needed
dim dx(8), dy(8)
dirs$= "0,1, 1,0, 0,-1, -1,0, -1,-1, 1,-1, -1,1, 1,1 "
for i = 1 to 8
'read dx, dy
dx=val(word$(dirs$,i*2-1, ","))
dy=val(word$(dirs$,i*2, ","))
dx(i)=dx:dy(i)=dy
next
for i = 0 to numR-1 'y
for j = 0 to numC-1 'x
if cas(j, i) <> 0 then c$(i,j)="#"
next
next
td = time$("ms")
pathLen=waveFront(STARTY,STARTX, ENDY,ENDX)
t = time$("ms") - td
#a.time, "Time : "; t; " ms."
#a.iter, "len( CList$ ) : ";pathLen
if pathLen then
#a.g "size 1; backcolor red; color red"
for k = 1 to pathLen-1 '0-th is Start, last is Fin
'print k, path(k, 1), path(k, 2)
y = path(k, 1)
x = path(k, 2)
#a.g "place ";(x-1)*c+(c/2);" ";(y-1)*c+(c/2);"; circlefilled 4"
next
#a.len, "Path lenght : ";pathLen
#a.g "backcolor white"
#a.g "Flush"
#a.g "Discard"
else
#a.len, "Path lenght : impossible... "
End If
end sub
function waveFront(startI,startJ,endI,endJ)
q$=startI;",";startJ;" " 'queue on a string - init
'print "Q_:";q$
redim a(numR,numC) 'should do before new run
a(startI,startJ)=1
while 1
if q$="" then exit function 'print "No way": gosub [showA]: goto [quit]
'pop from a queue
pos=instr(q$, " ")
curr$=left$(q$, pos-1)
q$=mid$(q$, pos+1)
'print "Q-:";q$
i=val(word$(curr$,1,","))
j=val(word$(curr$,2,","))
v=a(i,j)
'mark neighbours
for d = 1 to 4+ dia
ni=i+dy(d):nj=j+dx(d)
'print d, ni, nj', a(ni,nj), c$(ni,nj)
if ni>=0 and ni <numR and nj>=0 and nj <numC then
'if c$(ni,nj)="F" then
if ni=endI and nj=endJ then
a(ni,nj)=v+1
dirFrom(ni,nj)=d
found = 1
exit for
end if
if c$(ni,nj)<>"#" and a(ni,nj)=0 then
a(ni,nj)=v+1
dirFrom(ni,nj)=d
'add to queue
q$=q$;ni;",";nj;" "
if show then #a.g "backcolor darkgray; color darkgray; place ";(nj-1)*c+(c/2);" ";(ni-1)*c+(c/2);"; circlefilled 4"
'print "Q+:";q$
end if
end if
next
if found then exit while
wend
'next we'll need to get path from S to F...
'construct a path
pathLen=a(endI,endJ)-1
redim path(pathLen,2)
j=endJ:i=endI
'print i, j, a(i,j), dirFrom(i,j)
path(pathLen, 1)=i 'last is Fin, 0-th is Start
path(pathLen, 2)=j
for k = 1 to pathLen
d=dirFrom(i,j)
ni=i-dy(d):nj=j-dx(d) 'going back, hence '-'
path(pathLen-k, 1)=ni
path(pathLen-k, 2)=nj
'print k, ni, nj, dirFrom(ni,nj), a(ni,nj)
if a(ni, nj)=1 then exit for
i=ni:j=nj
next
waveFront=pathLen
end function
|
|
