; Written by Heathen
#cost = 10
#diagcost = 14
;{ Internal
Structure internal
g.l
open.l
parentx.l
parenty.l
EndStructure
Structure openlist
x.l
y.l
f.l
EndStructure
strucsize_.c = SizeOf(openlist)
Macro check(xx, yy, gg =#cost)
If xx > - 1 And yy > - 1 And xx < Width And yy < height And internal(xx, yy)\open > - 1
g = gg + internal(x, y)\g
p = array_2d(Priority, Width, xx, yy)
If p > 0
g/(100/p)
EndIf
If(internal(xx, yy)\open = 0 Or g < internal(xx, yy)\g)
xd = xend - xx
yd = yend - yy
If xd < 0 : xd * - 1 : EndIf
If yd < 0 : yd * - 1 : EndIf
internal(xx, yy)\g = g
internal(xx, yy)\parentx = x
internal(xx, yy)\parenty = y
If internal(xx, yy)\open > 0
openlist(internal(xx, yy)\open)\f = xd + yd + internal(xx, yy)\g
pos = internal(xx, yy)\open
Else
oc + 1
If oc/50 >= oa
oa + 1
ReDim openlist.openlist(oa*50)
EndIf
openlist(oc)\x = xx
openlist(oc)\y = yy
openlist(oc)\f = xd + yd + internal(xx, yy)\g
internal(xx, yy)\open = oc
pos = oc
EndIf
a = pos >> 1
While pos > 1 And openlist(pos)\f < openlist(a)\f
internal(openlist(pos)\x, openlist(pos)\y)\open = a
internal(openlist(a)\x, openlist(a)\y)\open = pos
CopyMemory(@openlist(pos), *temp, strucsize_)
CopyMemory(@openlist(a), @openlist(pos), strucsize_)
CopyMemory(*temp, @openlist(a), strucsize_)
pos = a
a = pos >> 1
Wend
EndIf
EndIf
EndMacro
Procedure.c array_2d(pointer, Width, field1, field2, pointer2 = 0)
If pointer > 0
Protected c = PeekC(pointer + field1*Width + field2)
If c = 0 And pointer2 > 0
c = PeekC(pointer2 + field1*Width + field2)
EndIf
ProcedureReturn c
EndIf
ProcedureReturn 0
EndProcedure
Procedure ray(x, y, xto, yto, blocked, Width, diag)
Protected xd, yd, a.w, b.w, d
*mem = AllocateMemory(8)
b = 0
Repeat
If array_2d(blocked, Width, x, y) = 1
FreeMemory(*mem)
ProcedureReturn 0
Else
PokeL(*mem + b*8, x)
PokeL(*mem + b*8 + 4, y)
b + 1
xd = xto - x
yd = yto - y
If xd < 0 : xd * - 1 : EndIf
If yd < 0 : yd * - 1 : EndIf
d = xd + yd
If(d > 2 And x <> xto And y <> yto And diag = 1) Or(d > 1 And(x = xto Or y = yto))
*mem = ReAllocateMemory(*mem,(b + 1)*8)
Else
ProcedureReturn *mem
EndIf
EndIf
a = 0
If xto > x : x + 1 : a = 1
ElseIf xto < x : x - 1 : a = 1
EndIf
If a = 0 Or diag = 1
If yto > y : y + 1
ElseIf yto < y : y - 1
EndIf
EndIf
ForEver
EndProcedure
;}
Procedure.l get_path(xstart, ystart, xend, yend, Width, height, allowdiag.c = 0, blockdiag.c = 0, blocked = 0, Priority = 0, cast_ray.c = 1, dynamic = 0, dynamic_size.w = 0, xoff.w = 0, yoff.w = 0, dynamic_count.w = 0)
If xstart = xend And yend = ystart
ProcedureReturn 0
EndIf
If cast_ray = 1
Protected r
r = ray(xend, yend, xstart, ystart, blocked, Width, allowdiag)
If r > 0
ProcedureReturn r
EndIf
EndIf
Shared strucsize_
Protected x, y, g, xx, yy, xd, yd, oc, pos, a, oa.w = 1, b1.c, b2.c, b3.c, b4.c, d.c = 0, dyn
Protected Dim openlist.openlist(50), Dim internal.internal(Width - 1, height - 1)
Protected *temp = AllocateMemory(strucsize_)
If dynamic > 0 And dynamic_size > 0 And dynamic_count > 0
Dim dynamic.c(Width - 1, height - 1)
dyn = @dynamic()
For x = 0 To dynamic_count - 1
xx = PeekL(dynamic + x*dynamic_size + xoff)
yy = PeekL(dynamic + x*dynamic_size + yoff)
dynamic(xx, yy) = 1
Next x
EndIf
x = xstart : y = ystart : internal(x, y)\open = - 1
Repeat
If x - 1 >= 0 : b1 = array_2d(blocked, Width, x - 1, y, dyn) : Else : b1 = 0 : EndIf
If x + 1 < Width : b2 = array_2d(blocked, Width, x + 1, y, dyn) : Else : b2 = 0 : EndIf
If y - 1 >= 0 : b3 = array_2d(blocked, Width, x, y - 1, dyn) : Else : b3 = 0 : EndIf
If y + 1 < height : b4 = array_2d(blocked, Width, x, y + 1, dyn) : Else : b4 = 0 : EndIf
If allowdiag
If array_2d(blocked, Width, x + 1, y - 1, dyn)= 0 And(blockdiag = 0 Or(blockdiag = 1 And(b2 = 0 Or b3 = 0)))
check(x + 1, y - 1, #diagcost)
EndIf
If array_2d(blocked, Width, x - 1, y + 1, dyn)= 0 And(blockdiag = 0 Or(blockdiag = 1 And(b1 = 0 Or b4 = 0)))
check(x - 1, y + 1, #diagcost)
EndIf
If array_2d(blocked, Width, x - 1, y - 1, dyn)= 0 And(blockdiag = 0 Or(blockdiag = 1 And(b1 = 0 Or b3 = 0)))
check(x - 1, y - 1, #diagcost)
EndIf
If array_2d(blocked, Width, x + 1, y + 1, dyn)= 0 And(blockdiag = 0 Or(blockdiag = 1 And(b2 = 0 Or b4 = 0)))
check(x + 1, y + 1, #diagcost)
EndIf
EndIf
If b1 = 0 : check(x - 1, y) : EndIf
If b2 = 0 : check(x + 1, y) : EndIf
If b3 = 0 : check(x, y - 1) : EndIf
If b4 = 0 : check(x, y + 1) : EndIf
If oc = 0
FreeMemory(*temp)
ProcedureReturn 0
EndIf
x = openlist(1)\x
y = openlist(1)\y
internal(x, y)\open = - 1
internal(openlist(oc)\x, openlist(oc)\y)\open = 1
CopyMemory(@openlist(oc), @openlist(1), strucsize_)
oc - 1
If oc > 1
pos = 1
Repeat
a = pos << 1
c = 0
If a <= oc And openlist(pos)\f >= openlist(a)\f
c = 1
EndIf
If a + 1 <= oc And openlist(pos)\f >= openlist(a + 1)\f And(c = 0 Or(c = 1 And openlist(a + 1)\f < openlist(a)\f))
a + 1
c = 1
EndIf
If c = 1
internal(openlist(pos)\x, openlist(pos)\y)\open = a
internal(openlist(a)\x, openlist(a)\y)\open = pos
CopyMemory(@openlist(pos), *temp, strucsize_)
CopyMemory(@openlist(a), @openlist(pos), strucsize_)
CopyMemory(*temp, @openlist(a), strucsize_)
pos = a
Else
Break 1
EndIf
ForEver
EndIf
Until(x = xend And y = yend)
pos = 0
*mem = AllocateMemory(320)
oa = 0
Repeat
PokeL(*mem + pos, x)
PokeL(*mem + pos + 4, y)
xx = internal(x, y)\parentx
yy = internal(x, y)\parenty
x = xx
y = yy
pos + 8
If x <> xstart Or y <> ystart
If pos/320 > oa
oa + 1
*mem = ReAllocateMemory(*mem,(oa + 1)*320)
EndIf
Else
Break
EndIf
ForEver
ReAllocateMemory(*mem, pos)
FreeMemory(*temp)
ProcedureReturn *mem
EndProcedure
Procedure path_get_size(*path)
If *path > 0
ProcedureReturn MemorySize(*path)/8
Else
ProcedureReturn - 1
EndIf
EndProcedure
Procedure path_get_x(*path, ind)
If *path > 0
Protected s.l
ind + 1
s = MemorySize(*path)
If((s -(ind*8))+ 4<= s Or ind = 0) And s > 0
ProcedureReturn PeekW(*path +(s -(ind*8)))
EndIf
EndIf
ProcedureReturn - 1
EndProcedure
Procedure path_get_y(*path, ind)
If *path > 0
Protected s.l
ind + 1
s = MemorySize(*path)
If((s -(ind*8))+ 8<= s Or ind = 0) And s > 0
ProcedureReturn PeekW((*path +(s -(ind*8)))+ 4)
EndIf
EndIf
ProcedureReturn - 1
EndProcedure
;{ The following procedures are optional 'utility' procedures.
Procedure is_node_at(*path, x, y)
If *path > 0
s = path_get_size(*path)
If s > 0
For i = 0 To s - 1
If path_get_x(*path, i) = x And path_get_y(*path, i) = y
ProcedureReturn 1
EndIf
Next i
EndIf
EndIf
ProcedureReturn 0
EndProcedure
Procedure validate_path(*path, Width, height, blocked, dynamic = 0, dynamic_size = 0, xoff = 0, yoff = 0, dynamic_count = 0)
If *path > 0
s = path_get_size(*path)
If s > 0
Protected dyn
If dynamic > 0 And dynamic_size > 0 And dynamic_count > 0
Dim dynamic.c(Width - 1, height - 1)
dyn = @dynamic()
For x = 0 To dynamic_count - 1
xx = PeekL(dynamic + x*dynamic_size + xoff)
yy = PeekL(dynamic + x*dynamic_size + yoff)
dynamic(xx, yy) = 1
Next x
EndIf
For i = 0 To s - 1
If array_2d(blocked, Width, path_get_x(*path, i), path_get_y(*path, i), dyn)
ProcedureReturn 0
EndIf
Next i
ProcedureReturn 1
EndIf
EndIf
ProcedureReturn 0
EndProcedure
Procedure.w nearest_node(*path, x, y, distalgo = 1)
min = 2147483647
sz = path_get_size(*path)
If sz > 0
For i = 0 To sz - 1
If distalgo = 1
s = Sqr(Pow(path_get_x(*path, i)- x, 2)+ Pow(path_get_y(*path, i)- y, 2))
Else
xd = path_get_x(*path, i)- x
yd = path_get_y(*path, i)- y
If xd < 0
xd * - 1
EndIf
If yd < 0
yd * - 1
EndIf
s = xd + yd
EndIf
If s < min
min = s
n = i
EndIf
Next i
ProcedureReturn n
Else
ProcedureReturn - 1
EndIf
EndProcedure
Procedure.c save_path(*path, filename.s)
If *path > 0
s = MemorySize(*path)
If s >= 8
f = CreateFile(#PB_Any, filename)
WriteData(f, *path, s)
CloseFile(f)
ProcedureReturn 1
EndIf
EndIf
ProcedureReturn 0
EndProcedure
Procedure load_path(filename.s)
sz = FileSize(filename)
If sz >= 8
*mem = AllocateMemory(sz)
f = ReadFile(#PB_Any, filename)
ReadData(f, *mem, sz)
CloseFile(f)
ProcedureReturn *mem
EndIf
ProcedureReturn 0
EndProcedure
;}
; HELP
; GET_PATH()
; path = get_path(xstart,ystart,xend,yend,width,height,[allowdiag,blockdiag,blocked,priority,cast_ray,dynamic,dyamic_size,xoff,yoff,dynamic_count)
; PARAMATERS
; xstart - x coord of the start of the path
; ystart - y coord of the start of the path
; xend - x coord of the end of the path
; yend - y coord of the end of the path
; width - Width of the path
; height - height of the path
; OPTIONAL PARAMETERS
; blocked - pointer to an array dimmed as char. The width and height must be the same as the width and height parameters (remember to subtract 1).
; ie dim blocked(width-1,height-1). 1 = square is blocked, 0 = square is free
; priorty - Same as above except 0-100. 100 = max priority.
; cast_ray - (1-0 boolean). If set to 1, the pathfinder will try a straight line first (taking diag into account).
; This can result in major speed improvements in some situations, and slight decrease in others.
; dynamic - This is a pointer to an array of structures. The structure must have x and y fields. This is for dynamic objects.
; dynamic_size - this is the size of the structure used in the array. You can use sizeof() to get this value.
; xoff - this is the offset in the structure of the x coordinate
; yoff - this is the offset in the structure of the y coordinate
; dynamic_count - this is the size of the array (which is being used).
; So if you use dim object(100) but there are only 5 objects, then you would set this argument to 5
; RETURNS 0 if a path is no possible, or a pointer to a memory block if successfull
; You then pass the pointer to the rest of the procedures which takes "path" as an argument
; If you are using dynamic objects, you can test to see if you need to make a new path
; by calling validate_path(). If it returns 0, then you need to call get_path() again because a dynamic (or static) object now lays in your path.
; VALIDATE_PATH()
; Validate_path()'s arguments are very similar to get_path(), so refer to the above for reference.
InitSprite()
InitMouse()
InitKeyboard()
#width = 50
#height = 50
Dim blocked.c(#width - 1, #height - 1)
Dim priority.c(#width - 1, #height - 1)
#tilesize = 10
; the following variables are entered into get_path()
; start
startx = 0
starty = 0
; destination
tox = 49
toy = 49
allowdiag = 1 ; allow moving diagonally?
blockdiag = 1 ; block diagonal movement between blocks? (assuming allowdiag = 1)
; use left button the mouse to lay blocks
; with shift+left button, you can increase the priority of the particular square
blocked(7, 4) = 1
blocked(7, 5) = 1
blocked(7, 6) = 1
blocked(7, 7) = 1
Macro draw()
StartDrawing(ImageOutput(0))
Box(0, 0, WindowWidth(0), WindowHeight(0))
For x = 1 To #width - 1
LineXY(x*#tilesize, 0, x*#tilesize, 640, #White)
Next x
For y = 1 To #height - 1
LineXY(0, y*#tilesize, 640, y*#tilesize, #White)
Next y
Box(starty*#tilesize, startx*#tilesize, #tilesize, #tilesize, #Yellow)
If *path > 0
n = nearest_node(*path, MouseX()/#tilesize, MouseY()/#tilesize, 0)
For a = 0 To path_get_size(*path)- 2
xx = path_get_x(*path, a)
yy = path_get_y(*path, a)
If xx > - 1 And yy > - 1
If n <> a
Box(xx*#tilesize, yy*#tilesize, #tilesize, #tilesize, #Green)
Else
Box(xx*#tilesize, yy*#tilesize, #tilesize, #tilesize, RGB(0, 100, 0))
EndIf
EndIf
Next a
EndIf
Box(tox*#tilesize, toy*#tilesize, #tilesize, #tilesize, #Blue)
For x = 0 To #width - 1
For y = 0 To #height - 1
If blocked(x, y)= 1
Box(x*#tilesize, y*#tilesize, #tilesize, #tilesize, #Red)
EndIf
Next y
Next x
StopDrawing()
EndMacro
*path = get_path(startx, starty, tox, toy, #width, #height, allowdiag, blockdiag, @blocked(), @priority())
OpenWindow(0, 0, 0, #tilesize*#width, #tilesize*#height, "", #PB_Window_ScreenCentered|#PB_Window_SystemMenu)
OpenWindowedScreen(WindowID(0), 0, 0, #tilesize*#width, #tilesize*#height, 0, 0, 0)
CreateImage(0, 640, 640, #PB_Image_DisplayFormat)
draw()
Repeat
event = WaitWindowEvent()
FlipBuffers(2)
StartDrawing(ScreenOutput())
DrawImage(ImageID(0), 0, 0)
Circle(MouseX(), MouseY(), #tilesize/3, #White)
StopDrawing()
ExamineKeyboard()
If IsScreenActive()= 0
ReleaseMouse(1)
Else
ReleaseMouse(0)
ExamineMouse()
EndIf
If KeyboardPushed(#PB_Key_LeftShift)
If MouseButton(#PB_MouseButton_Left) And priority(MouseX()/#tilesize, MouseY()/#tilesize) = 0
priority(MouseX()/#tilesize, MouseY()/#tilesize) = 10
If *path > 0
FreeMemory(*path)
EndIf
t = ElapsedMilliseconds()
*path = get_path(startx, starty, tox, toy, #width, #height, allowdiag, blockdiag, @blocked(), @priority())
SetWindowTitle(0, Str(ElapsedMilliseconds()- t))
draw()
ElseIf MouseButton(#PB_MouseButton_Right) And priority(MouseX()/#tilesize, MouseY()/#tilesize) = 10
priority(MouseX()/#tilesize, MouseY()/#tilesize) = 0
If *path > 0
FreeMemory(*path)
EndIf
t = ElapsedMilliseconds()
*path = get_path(startx, starty, tox, toy, #width, #height, allowdiag, blockdiag, @blocked(), @priority())
SetWindowTitle(0, Str(ElapsedMilliseconds()- t))
draw()
EndIf
Else
If MouseButton(#PB_MouseButton_Left) And blocked(MouseX()/#tilesize, MouseY()/#tilesize) = 0
blocked(MouseX()/#tilesize, MouseY()/#tilesize) = 1
If *path > 0
FreeMemory(*path)
EndIf
t = ElapsedMilliseconds()
*path = get_path(startx, starty, tox, toy, #width, #height, allowdiag, blockdiag, @blocked(), @priority())
SetWindowTitle(0, Str(ElapsedMilliseconds()- t))
draw()
ElseIf MouseButton(#PB_MouseButton_Right) And blocked(MouseX()/#tilesize, MouseY()/#tilesize) = 1
blocked(MouseX()/#tilesize, MouseY()/#tilesize) = 0
If *path > 0
FreeMemory(*path)
EndIf
t = ElapsedMilliseconds()
*path = get_path(startx, starty, tox, toy, #width, #height, allowdiag, blockdiag, @blocked(), @priority())
SetWindowTitle(0, Str(ElapsedMilliseconds()- t))
draw()
EndIf
EndIf
If KeyboardPushed(#PB_Key_Escape)
End
EndIf
Delay(1)
Until event = #PB_Event_CloseWindow
