Sorry your browser is not supported!

sync on
sync rate 15

#constant MAPWIDTH   5000
#constant MAPHEIGHT  5000
#constant CELLWIDTH  50
#constant CELLHEIGHT 50

`#constant MAPWIDTH   128
`#constant MAPHEIGHT  96
`#constant CELLWIDTH  4
`#constant CELLHEIGHT 4

global SourceX as integer
global SourceY as integer
global TargetX as integer
global TargetY as integer
global xxx as integer
global yyy as integer
global moving as integer
global counter as integer
global dist# as integer
global selected as integer
global selectedTileX as integer
global selectedTileZ as integer
selected=1
make object plain 20000,0,0
global object as integer
global r# as integer
  r# = 500

global ax# as integer
  ax#=45

global ay# as integer
  ay#=0

global ox# as integer
  ox#=matx/2*tilesize

global oy# as integer
  oy#=0

global oz# as integer
  oz#=matz/2*tilesize

global FOV# as integer
  FOV#=70
  set camera fov FOV#

global camSpeed as integer
  camSpeed = 50
object=1
counter=1
make matrix 1,MAPWIDTH,MAPHEIGHT,CELLWIDTH,CELLHEIGHT

CreateSearchMap(50,50)
CreateSearchPathLists(120)

DrawTheMap()
sync
sync

type characterObject
  sourceX as integer
  sourceY as integer
  targetX as integer
  targetY as integer
  counter as integer
  tempX as integer
  tempY as integer
  selected as integer
  moving as integer
endtype

global dim character(120) as characterObject

for f=101 to 111
  make object cube f,100
  color object f,RGB(255,0,0)
  character(f).tempX=rnd(CELLWIDTH)
  character(f).tempY=rnd(CELLHEIGHT)
next f
for f=1 to 100
  X=rnd(50)
  Y=rnd(50)
  SetSearchMap(X,Y,1)
  make object cube f,100
next f

do
   set cursor 0,0

   gosub camera
   gosub selectTile
   UserUpdateMap()
   DrawTheMap()

   sync
loop

selectTile:
    size=0
   rem Tile under mouse is?
   nearRng=screen width()
   selectedTileX=0
   selectedTileZ=0
   for tileX=1 to 50
      for tileZ=1 to 50
         x#=(tileX*100)-50
         z#=(tileZ*100)-50
         position object 20000,x#,get ground height(1,x#,z#),z#
         if object in screen(20000)
            dx#=abs(object screen x(20000)-mouseX())
            dz#=abs(object screen y(20000)-mouseY())
            rng=sqrt((dx#*dx#)+(dz#*dz#))
            if rng<nearRng
               nearRng=rng
               selectedTileX=tileX
               selectedTileZ=tileZ
            endIf
         endIf
      next tileZ
   next tileX

   rem Highlight Tile
   if selectedTileX>0
      ulX=-1 : ulY=-1
      urX=-1 : urY=-1
      brX=-1 : brY=-1
      blX=-1 : blY=-1

      `Top Left
      x#=(selectedTileX*100)-(size+1)*100 : z#=(selectedTileZ*100)-(size+1)*100
      position object 20000,x#,get ground height(1,x#,z#),z#
      if object in screen(20000)
         ulX=object screen x(20000)
         ulY=object screen y(20000)
      endIf

      `Top Right
      x#=selectedTileX*100 : z#=(selectedTileZ*100)-(size+1)*100
      position object 20000,x#,get ground height(1,x#,z#),z#
      if object in screen(20000)
         urX=object screen x(20000)
         urY=object screen y(20000)
      endIf

      `Bottom Right
      x#=selectedTileX*100 : z#=selectedTileZ*100
      position object 20000,x#,get ground height(1,x#,z#),z#
      if object in screen(20000)
         brX=object screen x(20000)
         brY=object screen y(20000)
      endIf

      `Bottom Left
      x#=(selectedTileX*100)-(size+1)*100 : z#=selectedTileZ*100
      position object 20000,x#,get ground height(1,x#,z#),z#
      if object in screen(20000)
         blX=object screen x(20000)
         blY=object screen y(20000)
      endIf

      ink RGB(255,128,0),0
      line ulX,ulY,urX,urY
      line blX,blY,brX,brY
      line ulX,ulY,blX,blY
      line urX,urY,brX,brY
      dec selectedTileX
      dec selectedTileZ
   endIf
return

Camera:

  mx=mousex()
  my=mousey()

  if (mouseclick()=0 and mousey()=0)
    ox#=ox#-camSpeed*sin(ay#)
    oz#=oz#-camSpeed*cos(ay#)
  endif
  if (mouseclick()=0 and mousey()=screen height()-1)
    ox#=ox#+camSpeed*sin(ay#)
    oz#=oz#+camSpeed*cos(ay#)
  endif
  if (mouseclick()=0 and mousex()=0)
    ox#=ox#+camSpeed*cos(ay#)
    oz#=oz#-camSpeed*sin(ay#)
  endif
  if (mouseclick()=0 and mousex()=screen width()-1)
    ox#=ox#-camSpeed*cos(ay#)
    oz#=oz#+camSpeed*sin(ay#)
  endif


  if r# > 100 and r#<2000
    if inkey$()="-" or inkey$()= "_" then inc r#,10
    if inkey$()="=" or inkey$()= "+" then dec r#,10
  endif
  if r# >= 2000 then r# = 1950
  if r# <= 100 then r#=100

  x#=ox#+r#*sin(ay#)*cos(ax#)
  y#=oy#+r#*sin(ax#)
  z#=oz#+r#*cos(ay#)*cos(ax#)

  position camera x#,y#,z#
  point camera ox#,oy#,oz#

return

function ProcessAStar4(f,SX,SY,TX,TY)
   Start = timer()
   Found = SearchMapAStar4(f, SX, SY, TX, TY)
   Time = timer()-Start
endfunction

function UserUpdateMap()

    X=selectedTileX
    Y=selectedTileZ
    for f=101 to 111
    Position object f ,character(f).sourceX*(MAPWIDTH/CELLWIDTH)+(MAPWIDTH/CELLWIDTH)/2, 0 ,character(f).sourceY*(MAPHEIGHT/CELLHEIGHT)+(MAPHEIGHT/CELLHEIGHT)/2
      if character(f).moving = 1
          if character(f).tempX=GetSearchPathX(f,character(f).counter) or character(f).tempY=GetSearchPathY(f,character(f).counter) then character(f).counter=character(f).counter+1
          ReadPath(character(f).counter,f,f)
          character(f).sourceX=character(f).tempX
          character(f).sourceY=character(f).tempY
      endif

      if character(f).counter = SearchPathSize(f) then character(f).moving=0
      if spacekey() then SetSearchMap(selectedTileX,selectedTileZ,1)
      if returnkey() then SetSearchMap(selectedTileX,selectedTileZ,0)
      if mouseclick() = 1 and X=character(f).sourceX and Y=character(f).sourceY and character(f).selected = 0
        character(f).selected = 1
      else
        if mouseclick() = 1 and X<>character(f).sourceX and Y<>character(f).sourceY
            character(f).selected = 0
        endif
      endif
      if mouseclick()=2 and character(f).selected=1
         character(f).targetX=selectedTileX
         character(f).targetY=selectedTileZ
         SX =character(f).sourceX
         SY =character(f).sourceY
         TX =character(f).targetX
         TY =character(f).targetY
         ProcessAStar4(f, SX ,SY ,TX ,TY)
         character(f).counter=0
        character(f).moving=1
      endif
      if character(f).selected=1
        color object f,RGB(0,0,255)
      endif
      if character(f).selected=0
        color object f,RGB(255,0,0)
      endif
      print character(f).targetX;":";
      print character(f).targetY;";;";SearchPathSize(f);";;";character(f).moving
      print character(f).counter;";;";character(f).sourceX;":";character(f).sourceY;";;";character(f).selected

    next f
endfunction

function DrawTheMap()
   object=1
   for X = 0 to CELLWIDTH
      for Y = 0 to CELLHEIGHT
         if GetSearchMap(X,Y) > 0 then Position object object,X*(MAPWIDTH/CELLWIDTH)+(MAPWIDTH/CELLWIDTH)/2,0,Y*(MAPHEIGHT/CELLHEIGHT)+(MAPHEIGHT/CELLHEIGHT)/2:inc object
      next Y
   next X

endfunction

function readPath(move,f,path)

    speed=1
    if GetSearchPathX(path,move)>character(f).tempX then character(f).tempX=character(f).tempX+speed
    if GetSearchPathY(path,move)>character(f).tempY then character(f).tempY=character(f).tempY+speed
    if GetSearchPathX(path,move)<character(f).tempX then character(f).tempX=character(f).tempX-speed
    if GetSearchPathY(path,move)<character(f).tempY then character(f).tempY=character(f).tempY-speed

endfunction



` MapAndSearch.dba

` Map and search routines

remstart
AVAILABLE FUNCTIONS*********************************************************************

CreateSearchMap(Width,Height)
   Create the map of the size specified

CreateSearchPathList(NoOfPaths)
   Create the paths of the quantity specified

SetSearchMap(X,Y,Value)
   Set an entry within the map (> 0 is not walkable)

GetSearchMap(X,Y)
   Read an entry from the map

GetSearchPathX(Path,Move)
   Get a X coordinate from the path specified

GetSearchPathY(Path,Move)
   Get a Y coordinate from the path specified

SearchPathSize(Path)
   Get the length of the specified path

SearchMapAStar8(Path,StartX,StartY,FinishX,FinishY)
   Run an 8 directional A* search, and store the results within the selected path

SearchMapAStar8R(Path,StartX,StartY,FinishX,FinishY)
   Run an 8 directional A* search, but disallow diagonal movement between blocked cells

SearchMapAStar4(Path,StartX,StartY,FinishX,FinishY)
   Run an 4 directional A* search, and store the results within the selected path

SearchMapFlood4(Path,StartX,StartY,FinishX,FinishY)
   Run a flood search, and store the results within the selected path

GetFlood4Cost(FinishX,FinishY)
   Uses the previous Flood4 search to identify the cost of the specified target

****************************************************************************************
remend

` ***********************
` Conditional Compilation
` ***********************

` Uncomment these three lines and comment the following three to enable the 'swap array items'.
` This command is a part of the matrix1array TPC DLL, and makes this stuff marginally faster.
#constant FASTSWAP_OFF  :
#constant FASTSWAP_ON   remstart
#constant FASTSWAP_END  remend
`#constant FASTSWAP_OFF  remstart
`#constant FASTSWAP_ON   remend
`#constant FASTSWAP_END  :


` ********************
` UDTs used internally
` ********************

type SEARCH_Position_t
   X as integer
   Y as integer
endtype

type SEARCH_TileInformation_t
   Status   as integer
   G        as integer
   H        as integer
   F        as integer
   ParentX  as integer
   ParentY  as integer
endtype

type SEARCH_OpenListItem_t
   F as integer
   X as integer
   Y as integer
endtype

` *************************************
` Global variables for library use only
` *************************************

global SEARCH_MapWidth  as integer
global SEARCH_MapHeight as integer
global SEARCH_MaxPaths as integer
global SEARCH_CurrentPosition as SEARCH_Position_t

` This is used for the new HEAP format using in A*
global SEARCH_OpenListSize as integer

` These are used for the flood4 search
global SEARCH_OpenListTop as integer
global SEARCH_OpenListBottom as integer

` Optimisation for flood4 search system
global SEARCH_PreviousStart as SEARCH_Position_t

` Note: these dims never actually get run - they are just here to declare the existance of the
`       arrays.
`       They are actually dimensioned in the Create* functions.
`       *This* is how you declare arrays in included files, and arrays where you don't know the
`       dimensions to use until run-time.

global dim SEARCH_Map(SEARCH_MapWidth, SEARCH_MapHeight) as integer
global dim SEARCH_TileInfo(SEARCH_MapWidth, SEARCH_MapHeight) as SEARCH_TileInformation_t
global dim SEARCH_OpenList(SEARCH_MapWidth * SEARCH_MapHeight) as SEARCH_OpenListItem_t
global dim SEARCH_SearchPath(SEARCH_MaxPaths, SEARCH_MapWidth * SEARCH_MapHeight) as SEARCH_Position_t
global dim SEARCH_PathSize(SEARCH_MaxPaths) as integer

` Initialised flags - by default DBPro sets them to zero. If they are not zero, then
` we are initialised.
global SEARCH_PathsInitialised as integer
global SEARCH_MapInitialised as integer

` ****************
` Public functions
` ****************

function CreateSearchMap(X as integer, Y as integer)
   SEARCH_MapWidth = X
   SEARCH_MapHeight = Y

   SEARCH_PreviousStart.X = -9999
   SEARCH_PreviousStart.Y = -9999

   undim SEARCH_Map()
   undim SEARCH_TileInfo()
   undim SEARCH_OpenList()

   global dim SEARCH_Map(X, Y) as integer
   global dim SEARCH_TileInfo(X, Y) as SEARCH_TileInformation_t
   global dim SEARCH_OpenList(X * Y) as SEARCH_OpenListItem_t

   SEARCH_MapInitialised=1
endfunction

function CreateSearchPathLists(Paths as integer)
   SEARCH_MaxPaths = Paths

   undim SEARCH_SearchPath()
   undim SEARCH_PathSize()

   global dim SEARCH_SearchPath(SEARCH_MaxPaths, SEARCH_MapWidth * SEARCH_MapHeight) as SEARCH_Position_t
   global dim SEARCH_PathSize(SEARCH_MaxPaths) as integer

   SEARCH_PathsInitialised = 1
endfunction

function SetSearchMap(X as integer, Y as integer, Value as integer)
   if SEARCH_MapInitialised = 0 then exitfunction
   if X < 0 or X >= SEARCH_MapWidth then exitfunction
   if Y < 0 or Y >= SEARCH_MapHeight then exitfunction
   SEARCH_PreviousStart.X = -9999
   SEARCH_Map(X,Y) = Value
endfunction

function GetSearchMap(X as integer, Y as integer)
   if SEARCH_MapInitialised = 0 then exitfunction
   if X < 0 or X >= SEARCH_MapWidth then exitfunction 0
   if Y < 0 or Y >= SEARCH_MapHeight then exitfunction 0
   exitfunction SEARCH_Map(X,Y)
endfunction 0

function GetSearchPathX(Path as integer, Move as integer)
   if SEARCH_PathsInitialised = 0 then exitfunction -1
   if Path < 0 or Path > SEARCH_MaxPaths then exitfunction -1
   if Move < 0 or Move > SEARCH_PathSize(Path) then exitfunction -1
   exitfunction SEARCH_SearchPath(Path, SEARCH_PathSize(Path)-Move).X
endfunction -1

function GetSearchPathY(Path as integer, Move as integer)
   if SEARCH_PathsInitialised = 0 then exitfunction -1
   if Path < 0 or Path > SEARCH_MaxPaths then exitfunction -1
   if Move < 0 or Move > SEARCH_PathSize(Path) then exitfunction -1
   exitfunction SEARCH_SearchPath(Path, SEARCH_PathSize(Path)-Move).Y
endfunction -1

function SearchPathSize(Path as integer)
   if SEARCH_PathsInitialised = 0 then exitfunction -1
   if Path >= 0 or Path <= SEARCH_MaxPaths then exitfunction SEARCH_PathSize(Path)
endfunction -1

function SearchMapAStar4(Path as integer, SX as integer, SY as integer, TX as integer, TY as integer)
   local X as integer
   local Y as integer
   local XOffset as integer
   local YOffset as integer
   local NewCost as integer

   if SEARCH_MapInitialised = 0 then exitfunction -1
   if SEARCH_PathsInitialised = 0 then exitfunction -1
   if Path < 0 or Path > SEARCH_MaxPaths then exitfunction -1

   SEARCH_PreviousStart.X = -9999
   SEARCH_InitialiseTileInfo(SX,SY)

   while SEARCH_GetLowestCostOpen() > 0

      for XOffset = -1 to 1

         X = SEARCH_CurrentPosition.X + XOffset
         if X >= 0 and X < SEARCH_MapWidth

            for YOffset = -1 to 1

               if (XOffset && YOffset) = 0
                  Y = SEARCH_CurrentPosition.Y + YOffset

                  if Y >= 0 and Y < SEARCH_MapHeight

                     if SEARCH_TileInfo(X,Y).Status = 0
                        SEARCH_TileInfo(X,Y).ParentX = SEARCH_CurrentPosition.X
                        SEARCH_TileInfo(X,Y).ParentY = SEARCH_CurrentPosition.Y
                        if X = TX then if Y = TY then exitfunction SEARCH_BuildPath(Path,SX,SY,TX,TY)
                        SEARCH_TileInfo(X,Y).Status = 1
                        SEARCH_TileInfo(X,Y).G = SEARCH_TileInfo(SEARCH_CurrentPosition.X,SEARCH_CurrentPosition.Y).G  + 10
                        SEARCH_TileInfo(X,Y).H = SEARCH_EstimateDistance(X,Y,TX,TY)
                        SEARCH_TileInfo(X,Y).F = SEARCH_TileInfo(X,Y).G + SEARCH_TileInfo(X,Y).H
                        SEARCH_AddToOpenList(X,Y)
                     else
                        if SEARCH_TileInfo(X,Y).Status = 1
                           NewCost = SEARCH_TileInfo(SEARCH_CurrentPosition.X,SEARCH_CurrentPosition.Y).G + 10
                           if SEARCH_TileInfo(X,Y).G > NewCost
                              SEARCH_TileInfo(X,Y).ParentX = SEARCH_CurrentPosition.X
                              SEARCH_TileInfo(X,Y).ParentY = SEARCH_CurrentPosition.Y
                              SEARCH_TileInfo(X,Y).G = NewCost
                              SEARCH_TileInfo(X,Y).F = NewCost + SEARCH_TileInfo(X,Y).H
                              SEARCH_AddToOpenList(X,Y)
                           endif
                        endif
                     endif
                  endif
               endif
            next YOffset
         endif
      next XOffset
   endwhile

   exitfunction SEARCH_ClearPath(Path,SX,SY)
endfunction 0

function GetFlood4Cost(TX as integer, TY as integer)
   if SEARCH_MapInitialised = 0 then exitfunction -1
   if SEARCH_PathsInitialised = 0 then exitfunction -1
   if SEARCH_PreviousStart.X <> -9999 then exitfunction SEARCH_TileInfo(TX,TY).F
endfunction -1

` **********************
` Internal-use functions
` **********************

function SEARCH_SingleStepCost(X as integer, Y as integer)
   if X = 0 or Y = 0 then exitfunction 10
endfunction 14

function SEARCH_EstimateDistance(X as integer, Y as integer, TX as integer, TY as integer)
   local Distance as integer
   Distance = (abs(X - TX) + abs(Y - TY))*10
endfunction Distance

function SEARCH_InitialiseTileInfo(SX as integer, SY as integer)
   SEARCH_OpenListSize=0

   SEARCH_PopulateTileInfo()

   SEARCH_TileInfo(SX, SY).G = 0
   SEARCH_TileInfo(SX, SY).H = SEARCH_EstimateDistance(SX, SY, TX, TY)
   SEARCH_TileInfo(SX, SY).F = SEARCH_TileInfo(SX, SY).H
   SEARCH_TileInfo(SX, SY).Status = 1
   SEARCH_TileInfo(SX, SY).ParentX = SX
   SEARCH_TileInfo(SX, SY).ParentY = SY

   SEARCH_AddToOpenList(SX, SY)
endfunction

function SEARCH_PopulateTileInfo()
   local X as integer
   local Y as integer

   for X = 0 to SEARCH_MapWidth
      for Y = 0 to SEARCH_MapHeight
         if SEARCH_Map(X,Y) > 0
            SEARCH_TileInfo(X,Y).Status=2
         else
            SEARCH_TileInfo(X,Y).Status=0
         endif
      next Y
   next X
endfunction

function SEARCH_AddToOpenList(X as integer, Y as integer)
   local Parent as integer
   local Child as integer
   local Cost as integer

   Child = SEARCH_OpenListSize
   inc SEARCH_OpenListSize

   Cost = SEARCH_TileInfo(X,Y).F

   do
      if Child <= 0 then exit

      Parent=(Child - 1)/2

      if SEARCH_OpenList(Parent).F < Cost then exit

      FASTSWAP_OFF
         SEARCH_OpenList(Child).F = SEARCH_OpenList(Parent).F
         SEARCH_OpenList(Child).X = SEARCH_OpenList(Parent).X
         SEARCH_OpenList(Child).Y = SEARCH_OpenList(Parent).Y
      FASTSWAP_ON
         swap array items SEARCH_OpenList(), Child, Parent
      FASTSWAP_END

      Child = Parent
   loop

   SEARCH_OpenList(Child).F = Cost
   SEARCH_OpenList(Child).X = X
   SEARCH_OpenList(Child).Y = Y
endfunction


function SEARCH_GetLowestCostOpen()
   local Parent as integer
   local Child as integer
   local Cost as integer

   if SEARCH_OpenListSize <= 0 then exitfunction 0

   dec SEARCH_OpenListSize

   SEARCH_CurrentPosition.X = SEARCH_OpenList(0).X
   SEARCH_CurrentPosition.Y = SEARCH_OpenList(0).Y

   Cost = SEARCH_OpenList( SEARCH_OpenListSize ).F

   FASTSWAP_OFF
      X = SEARCH_OpenList( SEARCH_OpenListSize ).X
      Y = SEARCH_OpenList( SEARCH_OpenListSize ).Y
   FASTSWAP_ON
   FASTSWAP_END

   Parent=0
   do
      Child=(2 * Parent) + 1
      if Child >= SEARCH_OpenListSize then exit

      if Child+1 < SEARCH_OpenListSize
         if SEARCH_OpenList(Child).F > SEARCH_OpenList(Child + 1).F then inc Child
      endif

      if SEARCH_OpenList(Child).F < Cost

         FASTSWAP_OFF
            SEARCH_OpenList(Parent).F = SEARCH_OpenList(Child).F
            SEARCH_OpenList(Parent).X = SEARCH_OpenList(Child).X
            SEARCH_OpenList(Parent).Y = SEARCH_OpenList(Child).Y
         FASTSWAP_ON
            swap array items SEARCH_OpenList(), Child, Parent
         FASTSWAP_END

         Parent = Child
      else
         exit
      endif
   loop

   FASTSWAP_OFF
      SEARCH_OpenList(Parent).F = Cost
      SEARCH_OpenList(Parent).X = X
      SEARCH_OpenList(Parent).Y = Y
   FASTSWAP_ON
      swap array items SEARCH_OpenList(), Parent, SEARCH_OpenListSize
   FASTSWAP_END

   if SEARCH_TileInfo(SEARCH_CurrentPosition.X,SEARCH_CurrentPosition.Y).Status = 2 then exitfunction SEARCH_GetLowestCostOpen()

   SEARCH_TileInfo(SEARCH_CurrentPosition.X,SEARCH_CurrentPosition.Y).Status = 2
endfunction 1

function SEARCH_QueueOntoOpen(X as integer, Y as integer)
   inc SEARCH_OpenListTop
   SEARCH_OpenList( SEARCH_OpenListTop ).X = X
   SEARCH_OpenList( SEARCH_OpenListTop ).Y = Y
endfunction

function SEARCH_UnqueueFromOpen()
   if SEARCH_OpenListBottom => SEARCH_OpenListTop then exitfunction 0

   inc SEARCH_OpenListBottom
   SEARCH_CurrentPosition.X = SEARCH_OpenList( SEARCH_OpenListBottom ).X
   SEARCH_CurrentPosition.Y = SEARCH_OpenList( SEARCH_OpenListBottom ).Y
endfunction 1

function SEARCH_BuildPath(Path as integer, SX as integer, SY as integer, TX as integer, TY as integer)
   Moves = 0
   X = TX
   Y = TY
   SEARCH_SearchPath(Path, Moves).X = X
   SEARCH_SearchPath(Path, Moves).Y = Y

   repeat
      inc Moves
      SEARCH_SearchPath(Path, Moves).X = SEARCH_TileInfo(X,Y).ParentX
      SEARCH_SearchPath(Path, Moves).Y = SEARCH_TileInfo(X,Y).ParentY
      X = SEARCH_SearchPath(Path, Moves).X
      Y = SEARCH_SearchPath(Path, Moves).Y
   until X = SX and Y = SY

   SEARCH_PathSize(Path) = Moves
endfunction Moves

function SEARCH_ClearPath(Path as integer, SX as integer, SY as integer)
   SEARCH_SearchPath(Path, 0).X=SX
   SEARCH_SearchPath(Path, 1).Y=SY
   SEARCH_PathSize(Path)=0
endfunction 0