Langton's ant

neil · Post by **neil** » Jan 14, 2024 20:16

Langton's ant takes 11655 steps to complete.
https://en.wikipedia.org/wiki/Langton%27s_ant

' Langton's ant
' compile with: fbc -s gui

ScreenRes 400,400,8 ' give a 100 by 100 field
Dim As UByte Ptr p = ScreenPtr
Dim As String key
If p = 0 Then End ' p does not point to screen

Palette 0,       0,   0,   0      ' index 0 = black
Palette 255,   255, 255, 255      ' index 225 = white

Line (0, 0) - (799, 799), 255, bf   ' draw box and fill it with white color

Dim As Integer count, offset, x = 199, y = 199
Dim As UByte col   ' = color
' direction, 0 = up, 1 = right, 2 = down, 3 = left
Dim As UByte d     ' d = 0, looking up

Do
  offset = x + y * 400
  col = p[offset]

  If col = 0 Then
    d = (d -1) And 3
  Else
    d = (d +1) And 3
  EndIf

  col = col Xor 255 ' flip the color

  ScreenLock
  Line (x, y) - (x +3, y -3), col, bf
  ScreenUnLock

 ' adjust as needed
  Sleep 5

  ' true = 0, false = -1
  If (d And 1) = 1 Then
    x = x + (d = 1) * 4 - (d = 3) * 4
  Else
    y = y - (d = 0) * 4 + (d = 2) * 4
  End If

  count += 1
  ' update step count window title bar
  WindowTitle "Langton's ant step: " + Str(count)

  ' has user clicked on close window "X" then end program
  If InKey = Chr(255) + "k" Then End
Loop Until x < 1 Or x > 398 Or y < 1 Or y > 398

' display total count in window title bar
WindowTitle "Langton's ant has left the field in " + Str(count) + " steps"
Do
key = Inkey
sleep 10,1
Loop Until (key = Chr(27)) Or (key = Chr(255) & "k")
End

badidea · Post by **badidea** » Jan 18, 2024 23:58

I made an ant that takes 45 degree turns. Keeps doing seemingly random walks.

Code: Select all

'define colors
const as ulong C_BLACK  = &hff000000
const as ulong C_YELLOW = &hffffff00
const as ulong C_RED    = &hffff0000
const as ulong C_GREEN  = &hff00ff00
const as ulong C_BLUE   = &hff0000ff

dim as ulong drawColor(0 to 1) = {C_BLACK, C_YELLOW} ', C_RED, C_GREEN, C_BlUE, C_YELLOW, C_RED, C_GREEN, C_BlUE}

'define map
const MAP_W = 400, MAP_H = 400
dim shared as integer map(MAP_W - 1, MAP_H - 1) '0 = black, 1 is white

'define screen
const DRAW_SCALE = 2
const SCRN_W = MAP_W * DRAW_SCALE, SCRN_H = MAP_H * DRAW_SCALE
screenres SCRN_W, SCRN_H, 32

'plot big pixels (right = x+, down = y+)
sub plot(x as integer, y as integer, c as ulong)
	line(x * DRAW_SCALE, y * DRAW_SCALE)-_
	step(DRAW_SCALE - 1, DRAW_SCALE - 1), c, bf
end sub

'set ant position and direction
dim as integer antx = MAP_W \ 2, anty = MAP_H \ 2 'start in center of map
dim as integer antdir = 2 '0 = up, 1 = right, 2 = down, 3 = left

'start ant walk
dim as string key
dim as integer steps = 0
color &hff00ff00,&hff000000
do
	if map(antx, anty) = 0 then 'at black
		antdir -= 1 'rotate left, counter-clockwise
		if antdir < 0 then antdir = 7
		map(antx, anty) = 1' antdir + 1
	'elseif map(antx, anty) = 1 then
	else
		antdir += 1 'rotate right, clockwise
		if antdir > 7 then antdir = 0
		map(antx, anty) = 0
	end if

	'screenlock
	plot(antx, anty, drawColor(map(antx, anty)))
	'locate 1,1: print str(antdir) + "," + str(antx) + "," + str(anty)  + " ";
	locate 2,1: print str(steps) + " ";
	'screenunlock
	
	'move ant forward
	select case antdir
		case 0 : anty -= 2 'up
		case 1 : anty -= 1 : antx += 1 'up/right
		case 2 : antx += 2 'right
		case 3 : antx += 1 : anty += 1 'right/down
		case 4 : anty += 2 'down
		case 5 : anty += 1 : antx -= 1 'down/left
		case 6 : antx -= 2 'left
		case 7 : antx -= 1 : anty -= 1 'left/up
	end select

	if antx < 0 or antx >= MAP_W then exit do
	if anty < 0 or anty >= MAP_H then exit do
	
	if steps mod 10 = 0 then sleep 10, 0 'sleep every X loops
	steps += 1
	key = inkey
loop while key = ""
print "End"
getkey()

badidea · Post by **badidea** » Jan 19, 2024 0:10

And the normal ant on a looped around map with some extra colors:

Code: Select all

'define colors
const as ulong C_BLACK  = &hff000000
const as ulong C_YELLOW = &hffffff00
const as ulong C_RED    = &hffff0000
const as ulong C_GREEN  = &hff00ff00
const as ulong C_BLUE   = &hff0000ff

dim as ulong drawColor(0 to 4) = {C_BLACK, C_YELLOW, C_RED, C_GREEN, C_BlUE}

'define map
const MAP_W = 400, MAP_H = 400
dim shared as integer map(MAP_W - 1, MAP_H - 1) '0 = black, 1 is white

'define screen
const DRAW_SCALE = 2
const SCRN_W = MAP_W * DRAW_SCALE, SCRN_H = MAP_H * DRAW_SCALE
screenres SCRN_W, SCRN_H, 32

'plot big pixels (right = x+, down = y+)
sub plot(x as integer, y as integer, c as ulong)
	line(x * DRAW_SCALE, y * DRAW_SCALE)-_
	step(DRAW_SCALE - 1, DRAW_SCALE - 1), c, bf
end sub

'set ant position and direction
dim as integer antx = MAP_W \ 2, anty = MAP_H \ 2 'start in center of map
dim as integer antdir = 2 '0 = up, 1 = right, 2 = down, 3 = left

'start ant walk
dim as string key
dim as integer steps = 0
color &hff00ff00,&hff000000
do
	if map(antx, anty) = 0 then 'at black
		antdir -= 1 'rotate left, counter-clockwise
		if antdir < 0 then antdir = 3
		map(antx, anty) = antdir + 1
	'elseif map(antx, anty) = 1 then
	else
		antdir += 1 'rotate right, clockwise
		if antdir > 3 then antdir = 0
		map(antx, anty) = 0
	end if

	'screenlock
	plot(antx, anty, drawColor(map(antx, anty)))
	'locate 1,1: print str(antdir) + "," + str(antx) + "," + str(anty)  + " ";
	locate 2,1: print str(steps) + " ";
	'screenunlock
	
	'move ant forward
	select case antdir
		case 0 : anty -= 1 'up
		case 1 : antx += 1 'right
		case 2 : anty += 1 'down
		case 3 : antx -= 1 'left
	end select
	
	'loop around
	if antx < 0 then antx = MAP_W - 1
	if anty < 0 then anty = MAP_H - 1
	if antx >= MAP_W then antx = 0
	if anty >= MAP_H then anty = 0
		
	if steps mod 100 = 0 then sleep 10, 0 'sleep every X loops
	steps += 1
	key = inkey
loop while key = ""
print "End"
getkey()

neil · Post by **neil** » Jan 19, 2024 0:23

@badidea
That's really cool what you did. We know who the ant expert is now.
I especially like the colorful one it looks something like a virtual ant farm.

That's an idea an ant farm with virtual ants digging tunnels.

Here's a real ant farm.
https://www.youtube.com/watch?v=cME_aMVUEVU

neil · Post by **neil** » Jan 19, 2024 5:22

My not-so-random ant is digging a tunnel simulator. My ant is invisible.
Changing variable r will increase or decrease the tunnel's diameter.
I think badidea could write a better algorithm for simulating random tunnel digging.

Code: Select all

Dim Shared As UShort i,x,y
Dim Shared As UByte cnt,n,r

Const As ULong blk = &HFF000000, brn = &HFF8B451B, ylw = &HFFFFF910

Declare Sub tunnel()
Screenres 1280,720,32,1,1
setmouse 0,0,0
Randomize
color blk,brn
cls
color ylw,blk
for y = 1 to 10
for x = 1 to 160:Locate y,x:Print " ";
next
next

Locate 2,20:Print "Press Esc to quit"
x = 120
DO

tunnel
IF multikey(&H01) THEN Exit Do
LOOP

Color ylw,blk
Locate 6,20:Print "Ended"
Sleep 1000,1
End

Sub tunnel()
  x -= 80 :y = 78: r = 3
  for i = 1 to 700
    n = int(rnd * 6) + 1
    if  n = 1 Then y += 1:x += 1
    if  n = 2 Then  y += 1
    if  n = 3 Then  x -= 1
    if  n = 4 THEN y += 1: x -=1
    if  n = 5 Then x += 1: y += 1
    if  n = 6 Then x += 1
    sleep 10,1
FOR cnt = 1 TO r
   IF multikey(&H01) THEN Exit For

   ' makes tunnel
   CIRCLE (x, y), cnt, blk
   CIRCLE (x,y + 1), cnt,blk

next
IF multikey(&H01) THEN Exit For
next
End Sub

badidea · Post by **badidea** » Jan 19, 2024 13:15

More interesting, I think, is a ant colony food finding simulation. Where ants search for food locations, find the way back to the nest with the food, mark a path to the food for others, optimize the path, switch to different location when the food runs out. Like here: https://onestepcode.com/ant-colony-simulation/

neil · Post by **neil** » Jan 19, 2024 19:08

@badidea
I think your idea is a good one. I know AI is not that easy to implement. A few months ago, I tried to have a mouse solve a maze. And then find the shortest route to get to the finish. I never did solve the problem. I was even looking into simple AI games where you play against a computer. I came across Dodicat's tic-tac-toe, and it was about 450 lines long. https://www.freebasic.net/forum/viewto ... d#p177178

I am interested in AI. That would be great if you implemented your idea.

badidea · Post by **badidea** » Jan 19, 2024 19:51

I posted a path search in 2016 using Dijkstra's algorithm, see: viewtopic.php?t=24542
I will give the ant idea a try. Might take some time...

The easy part is done, find food (yellow cell) by random walk.

Code: Select all

'An ant colony food finding simulation.
'Where ants:
'- search for food locations - done
'- find the way back to the nest with the food - todo
'- mark a path to the food for others - todo
'- optimize the path - todo
'- switch to different location when the food runs out - todo

#define hRGB(rgb_) ((((((rgb_) and &hF00) shl 4) or ((rgb_) and &hF00)) shl 8) or (((((rgb_) and &h0F0) shl 4) or ((rgb_) and &h0F0)) shl 4) or ((((rgb_) and &h00F) shl 4) or ((rgb_) and &h00F)))

'define colors
const as ulong C_BLACK  = hRGB(&h000) 'nest
const as ulong C_YELLOW = hRGB(&hFF0) 'food
const as ulong C_RED    = hRGB(&hF00) 'ant
const as ulong C_GREEN  = hRGB(&h0F0)
const as ulong C_BLUE   = hRGB(&h00F)
const as ulong C_BROWN  = hRGB(&h742) 'dirt
const as ulong C_GREY   = hRGB(&h777) 'rock / obstacle

'map cell types
const T_NONE = -1 'out of bounds
const T_DIRT = 0
const T_NEST = 1 'enty location to nest
const T_FOOD = 2
const T_OBST = 3 'obstacle

dim shared as ulong cellColor(0 to 3) = {C_BROWN, C_BLACK, C_YELLOW, C_GREY}

type cell_type
	dim as integer t 'type
	dim as integer nhm 'nest heat map
	dim as integer fhm 'food heat map
end type

'define map
const MAP_W = 100, MAP_H = 80
dim as cell_type map(MAP_W - 1, MAP_H - 1)

'define screen
const DRAW_SCALE = 8
const SCRN_W = MAP_W * DRAW_SCALE, SCRN_H = MAP_H * DRAW_SCALE
screenres SCRN_W, SCRN_H, 32
width SCRN_W \ 8, SCRN_H \ 16

'-------------------------------------------------------------------------------

'draw map cell (right = x+, down = y+)
sub drawCell(x as integer, y as integer, c as ulong)
	line(x * DRAW_SCALE, y * DRAW_SCALE)-_
	step(DRAW_SCALE - 1, DRAW_SCALE - 1), c, bf
end sub

'draw entire map, cell type values
sub drawMapT(map() as cell_type)
	for x as integer = 0 to ubound(map, 1)
		for y as integer = 0 to ubound(map, 2)
			dim as integer cellType = map(x, y).t
			drawCell(x, y, cellColor(cellType))
		next
	next
end sub

'draw entire map, heat map, hm: 0 = nest, 1 = food
sub drawMapHm(map() as cell_type, hm as integer)
	for x as integer = 0 to ubound(map, 1)
		for y as integer = 0 to ubound(map, 2)
			'dim as ulong c =
			'drawCell(x, y, c)
		next
	next
end sub

'set 'count' random locations to type,
'but not to close to border of map, determined by f
'e.g. (rnd * 0.8 + 0.1) => 0.1....0.9 range for f = 0.8
sub setRndPos(map() as cell_type, count as integer, cellType as integer, f as double)
	dim as double f2 = (1 - f) / 2
	for i as integer = 1 to count
		dim as integer x = int((rnd * f + f2) * ubound(map, 1))
		dim as integer y = int((rnd * f + f2) * ubound(map, 2))
		map(x, y).t = cellType
	next
end sub

function getCell(map() as cell_type, x as integer, y as integer) as integer
	if x < lbound(map, 1) then return T_NONE
	if x > ubound(map, 1) then return T_NONE
	if y < lbound(map, 2) then return T_NONE
	if y > ubound(map, 2) then return T_NONE
	return map(x, y).t
end function

'-------------------------------------------------------------------------------

'ant tasks
const FROZEN = 0 'or dead
const SEARCH_FOOD = 1 'random walk?
const GOTO_FOOD = 2
const GOTO_NEST = 3

const NUM_ANT = 10
type ant_type
	dim as integer x, y 'position on map
	dim as integer task
end type

dim as ant_type ant(NUM_ANT - 1)

'set rando start positions for the ants.
'TODO: set start position to a nest entrance location
for i as integer = 0 to ubound(ant)
	ant(i).x = int((rnd * 0.8 + 0.1) * MAP_W)
	ant(i).y = int((rnd * 0.8 + 0.1) * MAP_H)
	ant(i).task = SEARCH_FOOD
next

'smaller then cell
sub drawAnt(x as integer, y as integer, c as ulong)
	line(x * DRAW_SCALE + 1, y * DRAW_SCALE + 1)-_
	step(DRAW_SCALE - 3, DRAW_SCALE - 3), c, bf
end sub

sub drawAnts(ant() as ant_type)
	for i as integer = 0 to ubound(ant)
		'drawCell(ant(i).x, ant(i).y, C_RED)
		drawAnt(ant(i).x, ant(i).y, C_RED)
	next
end sub

'-------------------------------------------------------------------------------

'initialize map
randomize 7878 'timer
setRndPos(map(), 500, T_OBST, 0.9)
setRndPos(map(), 5, T_FOOD, 0.7)
setRndPos(map(), 3, T_NEST, 0.7)

dim as string key
dim as integer i, steps = 0
do
	'display stuff
	screenlock
	drawMapT(map())
	drawAnts(ant())
	for i = 0 to ubound(ant) 'list ant tasks
		draw string(10, 10 + i * 16), str(ant(i).task), C_GREEN
	next
	screenunlock
	
	'update ant positions and tasks
	for i = 0 to ubound(ant)
		with ant(i)
			select case .task
			case FROZEN
				'nothing
			case SEARCH_FOOD
				dim as integer antdir = int(rnd * 4)
				dim as integer oldx = .x
				dim as integer oldy = .y
				select case antdir
					case 0 : .y -= 1 'up
					case 1 : .x += 1 'right
					case 2 : .y += 1 'down
					case 3 : .x -= 1 'left
				end select
				dim as integer cellValue = getCell(map(), .x, .y)
				if cellValue = T_OBST or cellValue = T_NONE then
					.x = oldx 'reset position
					.y = oldy
				end if
				if cellValue = T_FOOD then .task = GOTO_NEST
			case GOTO_FOOD
				'if food found, goto_nest
				'if food gone???, search_food
			case GOTO_NEST
				'if nest found, goto_food
			end select
		end with
	next
	
	sleep 50,0
	steps += 1
	key = inkey
loop while key = ""
print "End"
getkey()

neil · Post by **neil** » Jan 20, 2024 0:49

@badidea
You have become quite a myrmecologist.
I did not expect anything for a few days.
Nice work. Thanks for sharing.

badidea · Post by **badidea** » Jan 20, 2024 23:38

Some progress. Ants now start at nest location and if the "N" key is being pressed the 'nest heat map' or 'distance to map' is shown.

Code: Select all

'https://www.freebasic.net/forum/viewtopic.php?p=301888#p301888
'An ant colony food finding simulation.
'Like here: https://onestepcode.com/ant-colony-simulation/
'Where ants:
'- search for food locations - done
'- find the way back to the nest with the food - todo
'- mark a path to the food for others - todo
'- optimize the path - todo
'- switch to different location when the food runs out - todo

#include "fbgfx.bi"

#define hRGB(rgb_) ((((((rgb_) and &hF00) shl 4) or ((rgb_) and &hF00)) shl 8) or (((((rgb_) and &h0F0) shl 4) or ((rgb_) and &h0F0)) shl 4) or ((((rgb_) and &h00F) shl 4) or ((rgb_) and &h00F)))

'define colors
const as ulong C_BLACK  = hRGB(&h000) 'nest
const as ulong C_YELLOW = hRGB(&hFF0) 'food
const as ulong C_RED    = hRGB(&hF00) 'ant
const as ulong C_GREEN  = hRGB(&h0F0)
const as ulong C_BLUE   = hRGB(&h00F)
const as ulong C_BROWN  = hRGB(&h742) 'dirt
const as ulong C_GREY   = hRGB(&h777) 'rock / obstacle

'map cell types
const T_NONE = -1 'out of bounds
const T_DIRT = 0
const T_NEST = 1 'enty location to nest
const T_FOOD = 2
const T_OBST = 3 'obstacle

dim shared as ulong cellColor(0 to 3) = {C_BROWN, C_BLACK, C_YELLOW, C_GREY}

type cell_type
	dim as integer t 'type
	dim as integer nhm 'nest heat map
	dim as integer fhm 'food heat map
end type

'define map
const MAP_W = 100, MAP_H = 80
dim as cell_type map(MAP_W - 1, MAP_H - 1)

'define screen
const DRAW_SCALE = 8
const SCRN_W = MAP_W * DRAW_SCALE, SCRN_H = MAP_H * DRAW_SCALE
screenres SCRN_W, SCRN_H, 32
width SCRN_W \ 8, SCRN_H \ 16

'-------------------------------------------------------------------------------

'draw map cell (right = x+, down = y+)
sub drawCell(x as integer, y as integer, c as ulong)
	line(x * DRAW_SCALE, y * DRAW_SCALE)-_
	step(DRAW_SCALE - 1, DRAW_SCALE - 1), c, bf
end sub

'draw entire map, cell type values
sub drawMapT(map() as cell_type)
	for x as integer = 0 to ubound(map, 1)
		for y as integer = 0 to ubound(map, 2)
			dim as integer cellType = map(x, y).t
			drawCell(x, y, cellColor(cellType))
		next
	next
end sub

'draw nest heat map
sub drawMapNhm(map() as cell_type)
	for x as integer = 0 to ubound(map, 1)
		for y as integer = 0 to ubound(map, 2)
			dim as integer value = 255 - map(x, y).nhm * 5
			if value < 0 then value = 0
			dim as ulong c = rgb(value, value, value)
			drawCell(x, y, c)
		next
	next
end sub

'set 'count' random locations to type,
'but not to close to border of map, determined by f
'e.g. (rnd * 0.8 + 0.1) => 0.1....0.9 range for f = 0.8
sub setRndPos(map() as cell_type, count as integer, cellType as integer, f as double)
	dim as double f2 = (1 - f) / 2
	for i as integer = 1 to count
		dim as integer x = int((rnd * f + f2) * ubound(map, 1))
		dim as integer y = int((rnd * f + f2) * ubound(map, 2))
		map(x, y).t = cellType
	next
end sub

function getCell(map() as cell_type, x as integer, y as integer) as integer
	if x < lbound(map, 1) then return T_NONE
	if x > ubound(map, 1) then return T_NONE
	if y < lbound(map, 2) then return T_NONE
	if y > ubound(map, 2) then return T_NONE
	return map(x, y).t
end function

'-------------------------------------------------------------------------------

'ant tasks
const FROZEN = 0 'or dead
const SEARCH_FOOD = 1 'random walk?
const GOTO_FOOD = 2
const GOTO_NEST = 3

type ant_type
	dim as integer x, y 'position on map
	dim as integer task
end type

const NUM_ANT = 10
dim as ant_type ant(NUM_ANT - 1)

'smaller then cell
sub drawAnt(x as integer, y as integer, c as ulong)
	line(x * DRAW_SCALE + 1, y * DRAW_SCALE + 1)-_
	step(DRAW_SCALE - 3, DRAW_SCALE - 3), c, bf
end sub

sub drawAnts(ant() as ant_type)
	for i as integer = 0 to ubound(ant)
		'drawCell(ant(i).x, ant(i).y, C_RED)
		drawAnt(ant(i).x, ant(i).y, C_RED)
	next
end sub

'-------------------------------------------------------------------------------

type nest_type
	dim as integer x, y 'position on map
end type

const NUM_NEST = 3 'entrance
dim as nest_type nest(NUM_NEST - 1)

'-------------------------------------------------------------------------------

randomize 7878 'timer

'initialize map
setRndPos(map(), 500, T_OBST, 0.9) 'set obstacles
setRndPos(map(), 5, T_FOOD, 0.7) 'set food positions
'set nest & food heat map to 'undiscovered' / far away
for x as integer = 0 to ubound(map, 1)
	for y as integer = 0 to ubound(map, 2)
		map(x, y).nhm = 99999
		map(x, y).fhm = 99999
	next
next
for i as integer = 0 to ubound(nest) 'set nests
	nest(i).x = int((rnd * 0.6 + 0.2) * MAP_W)
	nest(i).y = int((rnd * 0.6 + 0.2) * MAP_H)
	with map(nest(i).x, nest(i).y)
		.t = T_NEST 'mark on map
		.nhm = 0 'distance to nest is zero
	end with
next

'set ant start position to a nest entrance location
for i as integer = 0 to ubound(ant)
	dim as integer iNest = int(rnd * NUM_NEST)
	ant(i).x = nest(iNest).x
	ant(i).y = nest(iNest).y
	ant(i).task = SEARCH_FOOD
next

dim as integer showNhm = false, showFhm = false
dim as string key
dim as integer i, steps = 0
do
	'display stuff
	screenlock
	if showNhm then
		'show nest heat map
		drawMapNhm(map())
	elseif showFhm then
		'show food heat map
	else
		drawMapT(map())
	end if
	drawAnts(ant())
	draw string(10, 10), "<ESC> = exit, <N> nest heat map, <F> food heat map", C_GREEN
	for i = 0 to ubound(ant) 'list ant tasks
		draw string(10, 30 + i * 16), str(ant(i).task), C_GREEN
	next
	screenunlock
	
	'update ant positions and tasks
	for i = 0 to ubound(ant)
		with ant(i)
			select case .task
			case FROZEN
				'nothing
			case SEARCH_FOOD
				dim as integer antdir = int(rnd * 4)
				dim as integer oldx = .x
				dim as integer oldy = .y
				select case antdir
					case 0 : .y -= 1 'up
					case 1 : .x += 1 'right
					case 2 : .y += 1 'down
					case 3 : .x -= 1 'left
				end select
				dim as integer cellValue = getCell(map(), .x, .y)
				if cellValue = T_OBST or cellValue = T_NONE then
					.x = oldx 'reset position
					.y = oldy
				else 'step done
					'get prev. distance to nest
					dim as integer prevNestDist = map(oldx, oldy).nhm
					dim as integer thisNestDist = map(.x, .y).nhm
					if thisNestDist < prevNestDist then
						'implies already visited location & shorter path found, closer to nest
						map(oldx, oldy).nhm = thisNestDist + 1
					else
						map(.x, .y).nhm = prevNestDist + 1
					end if
					
				end if
				if cellValue = T_FOOD then .task = GOTO_NEST
			case GOTO_FOOD
				'if food found, goto_nest
				'if food gone???, search_food
			case GOTO_NEST
				'if nest found, goto_food
			end select
		end with
	next
	
	sleep 50,0 'shorter sleep to speed up
	steps += 1
	key = inkey
	if multikey(FB.SC_N) then showNhm = true else showNhm = false
	if multikey(FB.SC_F) then showFhm = true else showFhm = false
loop while not multikey(FB.SC_ESCAPE)
print "End"
getkey()

BasicCoder2 · Post by **BasicCoder2** » Jan 21, 2024 0:36

badidea,
Your ants finding food reminded me of the agent based programs I played with some years ago now. In this example the agents find mushrooms and return them to their home. They "wander" about until they find a mushroom and then use astar16 routine to find their home. This also includes a isometric display. I used data statements to include graphics in source code.

astar16.bas

Code: Select all

' uses a modified version of Patrick Lester's example as modified by coderJeff.
' http://www.execulink.com/~coder/freebasic/astar.html

#include once "fbgfx.bi"
const NULL = 0

type v2D
    as integer x
    as integer y
end type

type APATH
    as v2D p(1000)  'need to make this variable
    as integer pCount   'length of path
end type


const MAPW = 40
const MAPH = 30

const CELL_COUNT = MAPW * MAPH

#define CELLINDEX(x,y) ((MAPW*(y))+(x))

const STATE_NONE = 0
const STATE_OPEN = 1
const STATE_CLOSED = 2

type Cell
   x as integer
   y as integer
   IsSolid as integer
   parent as Cell Ptr
   state as integer     'open or closed
   f as integer
   g as integer
   h as integer
end type

dim shared Map( 0 to CELL_COUNT - 1 ) as CELL
dim shared StartIndex  as integer
dim shared pStartCell  as Cell ptr
dim shared EndIndex    as integer
dim shared pEndCell    as Cell ptr

sub CellClearAll()
   for y as integer = 0 to MAPH - 1
      for x as integer = 0 to MAPW - 1
         with Map( CELLINDEX(x,y) )
            .x = x
            .y = y
            .IsSolid  = FALSE
         end with
      next
   next
end sub

sub CellSetSolid( byval x as integer, byval y as integer, byval flag as integer )
   dim n as integer = CELLINDEX(x,y)
   Map( n ). IsSolid = flag
end sub

sub CellSetStart( byval x as integer, byval y as integer )
   StartIndex = CELLINDEX(x,y)
   pStartCell = @Map( StartIndex )
end sub

sub CellSetEnd( byval x as integer, byval y as integer )
   EndIndex = CELLINDEX(x,y)
   pEndCell = @Map( EndIndex )
end sub

sub CellToggleSolid( byval x as integer, byval y as integer )
   with Map( CELLINDEX(x,y) )
      if( .IsSolid ) then
         .IsSolid = FALSE
      else
         .IsSolid = TRUE
      end if
   end with
end sub




'' ------------------------------------------------------------------
'' A* Computations
'' ------------------------------------------------------------------

''
function ASTAR_GetLowestF( ) as CELL ptr
   dim c as CELL ptr = NULL
   for i as integer = 0 to CELL_COUNT - 1
      if( Map( i ).State = STATE_OPEN ) then
         if( c = NULL ) then
            c = @Map(i)
         else
            if( Map(i).f < c->f ) then
               c = @Map(i)
            end if
         end if
      end if
   next
   function = c
end function

''
function ASTAR_CheckNeighbour( byval parent as CELL ptr, byval x as integer, byval y as integer, cost as integer ) as integer
   function = FALSE
   if( x < 0 or x >= MAPW ) then
      exit function
   end if
   if( y < 0 or y >= MAPH ) then
      exit function
   end if
   dim c as CELL ptr = @Map( CELLINDEX(x, y) )
   if( c->IsSolid ) then
      exit function
   end if
   if( c->state = STATE_OPEN ) then
      if( parent->g + cost < c->g ) then
         c->state = STATE_NONE
      end if
   elseif( c->state = STATE_CLOSED ) then
      if( parent->g + cost < c->g ) then
         c->state = STATE_NONE
      end if
   end if
   if( c->state = STATE_NONE ) then
      c->state = STATE_OPEN
      c->g = parent->g + cost
      '' This is the Manhattan Distance Heuristic
      c->h = abs( c->x - pEndCell->x ) * 10 + abs( c->y - pEndCell->y ) * 10
      c->f = c->g + c->h
      c->parent = parent
   end if
   function = TRUE
end function

''
function ASTAR_CheckNeighbours( byval parent as CELL Ptr, byval x as integer, byval y as integer ) as integer
   const DIR_N = 1
   const DIR_S = 2
   const DIR_W = 4
   const DIR_E = 8
   dim flag as integer
   '' Check all orthogonal directions first N S E W
   if( ASTAR_CheckNeighbour( parent, x - 1, y    , 10 ) ) then
      flag or= DIR_W
   end if
   if( ASTAR_CheckNeighbour( parent, x    , y - 1, 10 ) ) then
      flag or= DIR_N
   end if
   if( ASTAR_CheckNeighbour( parent, x    , y + 1, 10 ) ) then
      flag or= DIR_S
   end if
   if( ASTAR_CheckNeighbour( parent, x + 1, y    , 10 ) ) then
      flag or= DIR_E
   end if
   '' Only allow a diagonal movement if both orthogonal
   '' directions are also allowed 
   if( ( flag and ( DIR_N or DIR_W )) = ( DIR_N or DIR_W ) ) then
      ASTAR_CheckNeighbour( parent, x - 1, y - 1, 14 )
   end if
   if( ( flag and ( DIR_S or DIR_W )) = ( DIR_S or DIR_W ) ) then
      ASTAR_CheckNeighbour( parent, x - 1, y + 1, 14 )
   end if
   if( ( flag and ( DIR_N or DIR_E )) = ( DIR_N or DIR_E ) ) then
      ASTAR_CheckNeighbour( parent, x + 1, y - 1, 14 )
   end if
   if( ( flag and ( DIR_S or DIR_E )) = ( DIR_S or DIR_E ) ) then
      ASTAR_CheckNeighbour( parent, x + 1, y + 1, 14 )
   end if
   function = 0
end function

''
sub ASTAR_Compute()
   dim c as CELL ptr
   for i as integer = 0 to CELL_COUNT - 1
      Map(i).parent = NULL
      Map(i).state = STATE_NONE
      Map(i).f = 0
      Map(i).g = 0
      Map(i).h = 0
   next
   c = pStartCell
   c->State = STATE_OPEN
   do
      c = ASTAR_GetLowestF()
      if( c = NULL ) then
         exit do
      elseif( c = pEndCell ) then
         exit do
      end if
      c->state = STATE_CLOSED
      ASTAR_CheckNeighbours( c, c->x, c->y )
   loop
end sub

function makePath(x2 as integer,y2 as integer,x1 as integer,y1 as integer) as APATH
    dim as APATH path
    dim as integer count
    CellSetStart(x2,y2)  'target
    CellSetEnd(x1,y1)
    ASTAR_Compute()
    dim c as CELL ptr = pEndCell
    
    path.pCount = 0
    while( c->parent )
        path.p(count).x = c->x
        path.p(count).y = c->y
        count = count + 1
        c = c->parent
    wend
    path.pCount = count
    return path
end function

mushroomCollectors.bas

Code: Select all

#include "astar16.bas"

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'   MAIN PROGRAM
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

const WORLDW = 40       'must be same as MAPW and MAPH in ASTAR ROUTINE HEADER
const WORLDH = 30

type AGENT
    as integer x         'current position
    as integer y
    as integer dx        'velocity between -1 and +1
    as integer dy
    as integer item      'item held by agent
    as integer itemCount 'count items collected
    
    'required for astar routine
    as APATH    path'path list
    as integer counter   'position so far
    as integer onThePath 'moving along path
    as v2D     target    'desired target
end type
dim shared as integer agentCount
agentCount = 4
dim shared as AGENT agents(0 to agentCount)
'===========================

const SCRW = 1340
const SCRH = 480

const TILEW = 16
const TILEH = 16

screenres SCRW, SCRH, 32
color rgb(0,0,0),rgb(255,255,255):cls

'====================================================================
' CREATE A TILE MAP AND FILL SOME TILES WITH IMAGES
'====================================================================

dim shared as any ptr worldBlock16
worldBlock16 = imagecreate(16*16,16*16,rgb(255,0,255))

dim as integer datum

for k as integer = 1 to 4
for j as integer = 0 to 15

    for i as integer = 0 to 15
        read datum
        
        if datum = 0 then
            pset worldBlock16,(i+k*16,j),rgb(255,0,255)
        end if

        if datum = 1 then
            pset worldBlock16,(i+k*16,j),rgb(255,0,0)
        end if
        
        if datum = 2 then
            pset worldBlock16,(i+k*16,j),rgb(0,0,255)
        end if
        
        if datum = 3 then
            pset worldBlock16,(i+k*16,j),rgb(0,255,0)
        end if
        
        if datum = 4 then
            pset worldBlock16,(i+k*16,j),rgb(136,0,21)
        end if
        
        if datum = 5 then
            pset worldBlock16,(i+k*16,j),rgb(195,195,195)
        end if
        
        if datum = 6 then
            pset worldBlock16,(i+k*16,j),rgb(0,0,0)
        end if
    next i

next j
next k

line worldBlock16,(240,0)-(240+15,15),rgb(0,0,0),bf

DATA 0,0,1,1,1,1,1,1,1,1,1,1,1,1,0,0
DATA 0,0,1,1,1,1,1,1,1,1,1,1,1,1,0,0
DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
DATA 1,1,1,1,0,0,1,1,1,1,0,0,1,1,1,1
DATA 1,1,1,1,0,0,1,1,1,1,0,0,1,1,1,1
DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
DATA 1,1,1,1,0,0,0,0,0,0,0,0,1,1,1,1
DATA 1,1,1,1,0,0,0,0,0,0,0,0,1,1,1,1
DATA 1,1,1,1,1,1,0,0,0,0,1,1,1,1,1,1
DATA 1,1,1,1,1,1,0,0,0,0,1,1,1,1,1,1
DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
DATA 0,0,1,1,1,1,1,1,1,1,1,1,1,1,0,0
DATA 0,0,1,1,1,1,1,1,1,1,1,1,1,1,0,0
DATA 0,0,2,2,2,2,2,2,2,2,2,2,2,2,0,0
DATA 0,0,2,2,2,2,2,2,2,2,2,2,2,2,0,0
DATA 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2
DATA 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2
DATA 2,2,2,2,0,0,2,2,2,2,0,0,2,2,2,2
DATA 2,2,2,2,0,0,2,2,2,2,0,0,2,2,2,2
DATA 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2
DATA 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2
DATA 2,2,2,2,0,0,0,0,0,0,0,0,2,2,2,2
DATA 2,2,2,2,0,0,0,0,0,0,0,0,2,2,2,2
DATA 2,2,2,2,2,2,0,0,0,0,2,2,2,2,2,2
DATA 2,2,2,2,2,2,0,0,0,0,2,2,2,2,2,2
DATA 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2
DATA 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2
DATA 0,0,2,2,2,2,2,2,2,2,2,2,2,2,0,0
DATA 0,0,2,2,2,2,2,2,2,2,2,2,2,2,0,0
DATA 0,0,0,0,0,0,0,6,6,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,6,6,0,0,0,0,0,0,0
DATA 0,0,0,0,0,6,6,3,3,6,6,0,0,0,0,0
DATA 0,0,0,0,0,6,6,3,3,6,6,0,0,0,0,0
DATA 0,0,0,6,6,3,3,3,3,3,3,6,6,0,0,0
DATA 0,0,0,6,6,3,3,3,3,3,3,6,6,0,0,0
DATA 0,6,6,3,3,3,3,3,3,3,3,3,3,6,6,0
DATA 0,6,6,3,3,3,3,3,3,3,3,3,3,6,6,0
DATA 0,6,6,3,3,3,3,3,3,3,3,3,3,6,6,0
DATA 0,6,6,3,3,3,3,3,3,3,3,3,3,6,6,0
DATA 0,0,0,6,6,6,6,6,6,6,6,6,6,0,0,0
DATA 0,0,0,6,6,6,6,6,6,6,6,6,6,0,0,0
DATA 0,0,0,0,0,6,6,4,4,6,6,0,0,0,0,0
DATA 0,0,0,0,0,6,6,4,4,6,6,0,0,0,0,0
DATA 0,0,0,6,6,6,6,6,6,6,6,6,6,0,0,0
DATA 0,0,0,6,6,6,6,6,6,6,6,6,6,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,6,6,6,6,6,6,0,0,0,0,0
DATA 0,0,0,0,0,6,6,6,6,6,6,0,0,0,0,0
DATA 0,0,0,6,6,5,5,5,5,5,5,6,6,0,0,0
DATA 0,0,0,6,6,5,5,5,5,5,5,6,6,0,0,0
DATA 0,6,6,5,5,5,5,5,5,5,5,5,5,6,6,0
DATA 0,6,6,5,5,5,5,5,5,5,5,5,5,6,6,0
DATA 0,6,6,6,6,6,6,5,5,6,6,6,6,6,6,0
DATA 0,6,6,6,6,6,6,5,5,6,6,6,6,6,6,0
DATA 0,0,0,0,0,6,6,6,6,6,6,0,0,0,0,0
DATA 0,0,0,0,0,6,6,6,6,6,6,0,0,0,0,0

'bload "tileBlock16A.bmp",worldBlock16    'load bitmap tile block

'====================================================================
'  ISOMETRIC DATA
'====================================================================

dim shared as any ptr ground0
ground0 = imagecreate(20,16)
dim shared as any ptr ground1
ground1 = imagecreate(20,16)

dim shared as any ptr imgAgent
imgAgent = imagecreate(20,57)

'dim shared as any ptr tree
'tree = imagecreate(20,57,rgb(255,0,255))
'bload "tree.bmp",tree

dim shared as any ptr mushy
mushy = imagecreate(15,12,rgb(255,0,255))
'bload "mushy.bmp",mushy

dim shared as any ptr man1
man1 = imagecreate(15,22)
'bload "man1.bmp",man1

dim shared as any ptr man2
man2 = imagecreate(15,22)
'bload "man2.bmp",man2

'ground tiles
dim as ulong c
for j as integer = 0 to 15
    for i as integer = 0 to 19
        read c
        
        if c = 0 then pset ground0,(i,j),rgb(255,0,255)
        if c = 1 then pset ground0,(i,j),rgb(0,0,0)
        if c = 2 then pset ground0,(i,j),rgb(200,100,0)
        
        if c = 0 then pset ground1,(i,j),rgb(255,0,255)
        if c = 1 then pset ground1,(i,j),rgb(0,0,0)
        if c = 2 then pset ground1,(i,j),rgb(100,200,0)
        
    next i
next j

'make man1
for j as integer = 0 to 21
    for i as integer = 0 to 14
        read c
        
        if c = 0 then pset man1,(i,j),rgb(255,0,255)
        if c = 1 then pset man1,(i,j),rgb(0,0,0)
        if c = 2 then pset man1,(i,j),rgb(255,255,255)
        if c = 3 then pset man1,(i,j),rgb(100,100,255)
        if c = 4 then pset man1,(i,j),rgb(255,0,0)
        
    next i
next j

'make man1
for j as integer = 0 to 21
    for i as integer = 0 to 14
        read c
        
        if c = 0 then pset man2,(i,j),rgb(255,0,255)
        if c = 1 then pset man2,(i,j),rgb(0,0,0)
        if c = 2 then pset man2,(i,j),rgb(255,255,255)
        if c = 3 then pset man2,(i,j),rgb(100,100,255)
        if c = 4 then pset man2,(i,j),rgb(255,0,0)
        
    next i
next j

'make mushy
for j as integer = 0 to 11
    for i as integer = 0 to 14
        read c
        
        if c = 0 then pset mushy,(i,j),rgb(255,0,255)
        if c = 1 then pset mushy,(i,j),rgb(0,0,0)
        if c = 2 then pset mushy,(i,j),rgb(255,255,255)
        if c = 3 then pset mushy,(i,j),rgb(100,100,255)
        if c = 4 then pset mushy,(i,j),rgb(255,0,0)
        
    next i
next j

'====================================================================

dim shared as integer sx,sy,ex,ey

dim shared as integer world(WORLDW,WORLDH)

'dim shared as any ptr floorBlock16
'floorBlock16 = imagecreate(16*16,16*16)

'bload "floorBlock16.bmp",floorBlock16    'load bitmap tile block
dim shared as integer floor(WORLDW,WORLDH)

'=========================================================================
'            DRAW ISOMETRIC DISPLAY OF WORLD
'=========================================================================
sub drawIsoWorld()
   
    dim as integer cx,cy     ' cx,cy origin on screen for isometric grid
    dim as integer x,y,z     ' x,y of point on normal 3D grid
    cx = 640+300
    cy = 160
    z = 0
    
    screenlock

    'display tiles
    for y as integer = 0 to WORLDH-1
        for x as integer = 0 to WORLDW-1
            if floor(x,y)=0 then
                put (cx-y*2*4+x*2*4-10,y*4+x*4+cy-5-z),ground0,trans
            else
                put (cx-y*2*4+x*2*4-10,y*4+x*4+cy-5-z),ground1,trans
            end if
        next x
    next y
    
    'overlay items
    for y as integer = 0 to WORLDH-1
        for x as integer = 0 to WORLDW-1
            'overlay agents
            for i as integer = 0 to agentCount
                if (agents(i).y\16) <= y then
                    if agents(i).item = 0 then
                        put (cx - (agents(i).y\4)*2 + (agents(i).x\4)*2-10, (agents(i).y\4) + (agents(i).x\4) + cy - z- 12),man1,trans
                    else
                        put (cx - (agents(i).y\4)*2 + (agents(i).x\4)*2-10, (agents(i).y\4) + (agents(i).x\4) + cy - z- 12),man2,trans 
                    end if
                end if
            next i
            
            if world(x,y)=3 then
                'put (cx-y*2*4+x*2*4-8,y*4+x*4+cy-45-z),tree,trans
            elseif world(x,y)=4 then
                put (cx-y*2*4+x*2*4-10,y*4+x*4+cy-8-z),mushy,trans
            end if  
        next x
    next y
    


    
    screenunlock
end sub
'========================================================================



sub drawWorld()
    dim as integer x,y,n
    screenlock
    
    cls
    for j as integer = 0 to  WORLDH-1
        for i as integer = 0 to WORLDW-1
                if floor(i,j)=0 then
                    line (i*TILEW,j*TILEh)-(i*TILEW+TILEW-1,j*TILEH+TILEH-1),rgb(200,100,0),bf  'floor tile color
                else
                    line (i*TILEW,j*TILEh)-(i*TILEW+TILEW-1,j*TILEH+TILEH-1),rgb(100,200,0),bf
                end if
            if world(i,j)<>0 then
                n = world(i,j)  'get tile id
                y = int(n/16) 'compute position in tile block
                x = n-(16*y)
                put (i*TILEW,j*TILEH),worldBlock16,(x*TILEW,y*TILEH)-(x*TILEW+TILEW-1,y*TILEH+TILEH-1),trans
                line (i*TILEW,j*TILEH)-(i*TILEW+TILEW,j*TILEH+TILEH),rgb(0,0,200),b
            end if
            line (i*TILEW,j*TILEH)-(i*TILEW+TILEH,j*TILEW+TILEH),rgb(100,100,100),b
        next i
    next j
    
    'draw agents
    for i as integer = 0 to agentCount
        
        if agents(i).item = 0 then
            put (agents(i).x,agents(i).y),worldBlock16,(2*TILEW,0*TILEH)-(2*TILEW+TILEW-1,0*TILEH+TILEH-1),trans
        else
            put (agents(i).x,agents(i).y),worldBlock16,(1*TILEW,0*TILEH)-(1*TILEW+TILEW-1,0*TILEH+TILEH-1),trans
        end if
        
        put (agents(i).target.x*TILEW,agents(i).target.y*TILEH),worldBlock16,(15*TILEW,0*TILEH)-(15*TILEW+TILEW-1,0*TILEH+TILEH-1),trans
        draw string (agents(i).x-8,agents(i).y),str(i)
        locate (i+1)*2,82
        print "agent";i;
        'draw mushrooms
        for j as integer = 0 to agents(i).itemCount-1
            put (716+j*16,i*16),worldBlock16,(4*TILEW,0*TILEH)-(4*TILEW+TILEW-1,0*TILEH+TILEH-1),trans
        next j

    next i
    
    screenunlock
end sub


sub fillWorld()
    for y as integer = 3 to MAPH-5
        for x as integer = 0 to MAPW-1
            floor(x,y)=int(rnd(1)*2)
            if int(rnd(1)*8)=0 then
                CellSetSolid(x,y, TRUE )
                if int(rnd(1)*4)=0 then
                    world(x,y)=4  'mushroom
                else
                    world(x,y)=3  'tree
                end if
            end if
        next x
    next y
end sub


sub followPath(ag as AGENT)

    if ag.counter < ag.path.pCount then
        ag.dx = ag.path.p(ag.counter).x - (ag.x\16)    'get direction to move
        ag.dy = ag.path.p(ag.counter).y - (ag.y\16)
        ag.counter = ag.counter + 1        'bump counter
    else
        ag.onThePath = 0
        ag.item = 0       'drop item
        ag.itemCount = ag.itemCount + 1  'count items dropped
        ag.dx = 0
        ag.dy = 0
    end if
    
end sub

sub moveAgents(ag as AGENT)
        dim as integer hit
        dim as integer TILEX,TILEY
        
        hit = 0
        ag.x = ag.x + ag.dx
        ag.y = ag.y + ag.dy
        
        'out of bounds
        if ag.x < 0 or ag.x > 640-16 or ag.y < 0 or ag.y > 480-16 then hit = 1

        'test overlap of another tile
        TILEX = int(ag.x/16)
        TILEY = int(ag.y/16)
        if world(TILEX,TILEY)<>0 then hit = 1

        TILEX = int((ag.x+15)/16)
        TILEY = int((ag.y)/16)
        if world(TILEX,TILEY)<>0 then hit = 1

        TILEX = int((ag.x)/16)
        TILEY = int((ag.y+15)/16)
        if world(TILEX,TILEY)<>0 then hit = 1

        TILEX = int((ag.x+15)/16)
        TILEY = int((ag.y+15)/16)
        if world(TILEX,TILEY)<>0 then hit = 1

        if hit = 1 then
            ag.x = ag.x - ag.dx 'undo move
            ag.y = ag.y - ag.dy 
            'new trial
            ag.dx = int(rnd(1)*3)-1
            ag.dy = int(rnd(1)*3)-1
            while ag.dx = 0 and ag.dy = 0
                ag.dx = int(rnd(1)*3)-1
                ag.dy = int(rnd(1)*3)-1  
            wend
        end if
        
end sub


sub update()
    
    dim as integer onTile
    
    for i as integer = 0 to agentCount
        
        'test if on center of tile
        onTile = 0
        if agents(i).x = int(agents(i).x\16)*16 and agents(i).y = int(agents(i).y\16)*16 then
            onTile = 1
        end if
        
        if onTile = 1 then
            
            dim as integer p,q
            if agents(i).onThePath = 1 then
                
                followPath(agents(i))

            else
        
                'random change in direction
                if int(rnd(1)*20)=0 then
                    agents(i).dx = int(rnd(1)*3)-1
                    agents(i).dy = int(Rnd(1)*3)-1
                    while agents(i).dx = 0 and agents(i).dy = 0
                        agents(i).dx = int(rnd(1)*3)-1
                        agents(i).dy = int(Rnd(1)*3)-1 
                    wend
                end if

                'check for mushroom
                for jj as integer = -1 to 1
                    for ii as integer = -1 to 1
                        p = agents(i).x\16+ii
                        q = agents(i).y\16+jj
                        if p>0 and p<640 and q>0 and q<480 and agents(i).onThePath = 0 then
                            if world(p,q) = 4 then       'FOUND MUSHROOM
                                world(p,q) = 0           'remove from world
                                CellSetSolid(p,q,FALSE)  'remove from ASTAR MAP
                                agents(i).item = 1       'agent now holding an item
                                agents(i).path = makePath(agents(i).target.x,agents(i).target.y,(agents(i).x\16),(agents(i).y\16))
                                agents(i).onThePath = 1
                                agents(i).counter = 0    'zero agent current index position on path
                            end if
                        end if
                    next ii
                next jj
            
            end if
            
        end if
        
        
        moveAgents(agents(i))

        
    next i

    drawWorld()
    drawIsoWorld()
    
end sub

'dim as integer x,y

CellClearAll()
'fill world with mushrooms and trees
fillWorld()

'loadMap("bigWorld.txt")


for i as integer = 0 to agentCount
    agents(i).x = i*8*16
    agents(i).y = 2*16
    agents(i).target.x = i*8
    agents(i).target.y = 28
    agents(i).dx = int(rnd(1)*3)-1
    agents(i).dy = int(Rnd(1)*3)-1
    while agents(i).dx = 0 and agents(i).dy = 0
        agents(i).dx = int(rnd(1)*3)-1
        agents(i).dy = int(Rnd(1)*3)-1 
    wend
next i

dim as double now1
now1 = timer

do
    
    if timer > now1 + 0.01 then
        now1 = timer
        update()
    end if
    
    sleep 2

loop until multikey(&H01)

'ground
data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,1,1,2,2,1,1,0,0,0,0,0,0,0
data 0,0,0,0,0,1,1,2,2,2,2,2,2,1,1,0,0,0,0,0
data 0,0,0,1,1,2,2,2,2,2,2,2,2,2,2,1,1,0,0,0
data 0,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,0
data 1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1
data 0,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,0
data 0,0,0,1,1,2,2,2,2,2,2,2,2,2,2,1,1,0,0,0
data 0,0,0,0,0,1,1,2,2,2,2,2,2,1,1,0,0,0,0,0
data 0,0,0,0,0,0,0,1,1,2,2,1,1,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,0,0

'man1
DATA 0,0,1,1,1,1,1,1,1,1,1,1,1,0,0
DATA 0,1,1,1,1,1,1,1,1,1,1,1,1,1,0
DATA 0,1,1,1,1,3,3,1,3,3,1,1,1,1,0
DATA 0,1,1,1,1,3,3,1,3,3,1,1,1,1,0
DATA 0,1,1,1,1,3,3,1,3,3,1,1,1,1,0
DATA 0,0,0,1,1,1,1,1,1,1,1,1,0,0,0
DATA 0,0,0,1,1,4,4,4,4,4,1,1,0,0,0
DATA 0,0,1,1,1,4,4,4,4,4,1,1,1,0,0
DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
DATA 1,1,0,0,1,1,1,1,1,1,1,0,0,1,1
DATA 1,1,0,0,1,1,1,1,1,1,1,0,0,1,1
DATA 1,1,0,0,1,1,1,1,1,1,1,0,0,1,1
DATA 1,1,0,0,1,1,1,1,1,1,1,0,0,1,1
DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
DATA 0,0,1,1,1,1,1,1,1,1,1,1,1,0,0
DATA 0,0,0,0,1,1,1,1,1,1,1,0,0,0,0
DATA 0,0,0,1,1,1,0,0,0,1,1,1,1,0,0
DATA 0,0,1,1,1,0,0,0,0,0,1,1,1,0,0
DATA 1,1,1,1,1,0,0,0,0,0,1,1,1,1,1
DATA 0,1,1,1,0,0,0,0,0,0,0,1,1,1,1
DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0

'man2
DATA 0,0,1,1,1,1,1,1,1,1,1,1,1,0,0
DATA 0,1,1,1,1,1,1,1,1,1,1,1,1,1,0
DATA 0,1,1,1,1,3,3,1,3,3,1,1,1,1,0
DATA 0,1,1,1,1,3,3,1,3,3,1,1,1,1,0
DATA 0,1,1,1,1,3,3,1,3,3,1,1,1,1,0
DATA 0,0,0,1,1,1,1,1,1,1,1,1,0,0,0
DATA 0,0,0,1,1,4,4,4,4,4,1,1,0,0,0
DATA 0,0,1,1,1,4,4,4,4,4,1,1,1,0,0
DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
DATA 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
DATA 1,1,1,1,2,2,2,2,2,2,2,1,1,1,1
DATA 1,1,1,2,2,2,2,2,2,2,2,2,1,1,1
DATA 1,1,1,2,2,2,2,2,2,2,2,2,2,1,1
DATA 1,1,2,2,2,2,2,2,2,2,2,2,2,1,1
DATA 1,1,1,1,1,1,2,2,2,1,1,1,1,1,1
DATA 0,0,1,1,1,1,2,2,2,1,1,1,1,0,0
DATA 0,0,0,0,1,1,2,2,2,1,1,0,0,0,0
DATA 0,0,0,1,1,1,2,2,2,1,1,1,1,0,0
DATA 0,0,1,1,1,0,0,0,0,0,1,1,1,0,0
DATA 1,1,1,1,1,0,0,0,0,0,1,1,1,1,1
DATA 0,1,1,1,0,0,0,0,0,0,0,1,1,1,1
DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0

'mushy
DATA 0,0,0,0,1,1,1,1,1,1,1,0,0,0,0
DATA 0,0,1,1,2,2,2,2,2,2,2,1,1,0,0
DATA 0,1,2,2,2,2,2,2,2,2,2,2,2,1,0
DATA 1,2,2,2,2,2,2,2,2,2,2,2,2,2,1
DATA 1,2,2,2,2,2,2,2,2,2,2,2,2,2,1
DATA 1,2,2,2,2,2,2,2,2,2,2,2,2,2,1
DATA 0,1,1,1,1,1,1,1,1,1,1,1,1,1,0
DATA 0,0,0,0,0,1,2,2,2,1,0,0,0,0,0
DATA 0,0,0,0,0,1,2,2,2,1,0,0,0,0,0
DATA 0,0,0,0,0,1,2,2,2,1,0,0,0,0,0
DATA 0,0,0,0,0,1,2,2,2,1,0,0,0,0,0
DATA 0,0,0,0,0,0,1,1,1,0,0,0,0,0,0

badidea · Post by **badidea** » Jan 21, 2024 1:28

Nice artwork, the agents look like bears. My ants however, will not use A*, they will use the Ant* algoritm.

neil · Post by **neil** » Jan 21, 2024 4:37

Ant colony on the move.

Code: Select all

' ant colony on the move by neil

const W = 800
const H = 600

const ANT_COUNT = 160
const ANT_SIZE = 5

dim shared as integer antX(ANT_COUNT)
dim shared as integer antY(ANT_COUNT)
dim shared as integer antDX(ANT_COUNT)
dim shared as integer antDY(ANT_COUNT)

sub moveAnt(index as integer)
    antX(index) += antDX(index)
    antY(index) += antDY(index)
    
    ' Check boundary collision
    if antX(index) < 0 or antX(index) > W - ANT_SIZE then
        antDX(index) = -antDX(index)
    end if
    if antY(index) < 0 or antY(index) > H - ANT_SIZE then
        antDY(index) = -antDY(index)
    end if
end sub

sub drawAnts()
    Screenlock
    Cls
    
    for index as integer = 0 to ANT_COUNT - 1
        line (antX(index), antY(index)) - (antX(index) + ANT_SIZE, antY(index) + ANT_SIZE)
    next
    
    Screenunlock
end sub

sub initializeAnts()
    randomize timer
    
    for index as integer = 0 to ANT_COUNT - 1
        antX(index) = rnd * (W - ANT_SIZE)
        antY(index) = rnd * (H - ANT_SIZE)
        
        antDX(index) = 1 - int(rnd * 2)
        antDY(index) = 1 - int(rnd * 2)
    next
end sub

sub updateAnts()
    for index as integer = 0 to ANT_COUNT - 1
        moveAnt(index)
    next
end sub

sub Start()
    initializeAnts()
    
    do
        updateAnts()
        drawAnts()
        
        sleep 10,1
    loop until inkey = chr(27)
    
end sub

screenres W, H, 32,,1
Setmouse 0,0,0

Start

badidea · Post by **badidea** » Jan 21, 2024 19:14

Nest step implemented: Finding way back to nest with the food.
Color of ant: red = food search, blue = food to nest, green = to food source (not yet implemented)
The "N" key still works, to see the world as an ant.
The random walk BTW, is amazingly inefficient for finding something. I hope that real ant are smarter.

Code: Select all

'https://www.freebasic.net/forum/viewtopic.php?p=301888#p301888
'An ant colony food finding simulation.
'Like here: https://onestepcode.com/ant-colony-simulation/
'Where ants:
'- search for food locations - done
'- find the way back to the nest with the food - done
'- mark a path to the food for others - todo
'- optimize the path - todo
'- switch to different location when the food runs out - todo

'TODO:
'- change cell types to bitmask

#include "fbgfx.bi"

#define hRGB(rgb_) ((((((rgb_) and &hF00) shl 4) or ((rgb_) and &hF00)) shl 8) or (((((rgb_) and &h0F0) shl 4) or ((rgb_) and &h0F0)) shl 4) or ((((rgb_) and &h00F) shl 4) or ((rgb_) and &h00F)))

'define colors
const as ulong C_BLACK  = hRGB(&h000) 'nest
const as ulong C_YELLOW = hRGB(&hFF0) 'food
const as ulong C_RED    = hRGB(&hF00) 'ant
const as ulong C_LGREEN = hRGB(&h0F0)
const as ulong C_DGREEN = hRGB(&h080)
const as ulong C_BLUE   = hRGB(&h22F)
const as ulong C_BROWN  = hRGB(&h742) 'dirt
const as ulong C_LGREY  = hRGB(&h777) 'rock / obstacle
const as ulong C_DGREY  = hRGB(&h444) 'rock / obstacle

'map cell types
const T_NONE = -1 'out of bounds
const T_DIRT = 0
const T_NEST = 1 'enty location to nest
const T_FOOD = 2
const T_OBST = 3 'obstacle

dim shared as ulong cellColor(0 to 3) = {C_BROWN, C_BLACK, C_YELLOW, C_LGREY}

type cell_type
	dim as integer t 'type
	dim as integer nhm 'nest heat map
	dim as integer fhm 'food heat map
end type

'define map
const MAP_W = 100, MAP_H = 80
dim as cell_type map(MAP_W - 1, MAP_H - 1)

'define screen
const DRAW_SCALE = 8
const SCRN_W = MAP_W * DRAW_SCALE, SCRN_H = MAP_H * DRAW_SCALE
screenres SCRN_W, SCRN_H, 32
width SCRN_W \ 8, SCRN_H \ 16

'-------------------------------------------------------------------------------

'draw map cell (right = x+, down = y+)
sub drawCell(x as integer, y as integer, c as ulong)
	line(x * DRAW_SCALE, y * DRAW_SCALE)-_
	step(DRAW_SCALE - 1, DRAW_SCALE - 1), c, bf
end sub

'draw entire map, cell type values
sub drawMapT(map() as cell_type)
	for x as integer = 0 to ubound(map, 1)
		for y as integer = 0 to ubound(map, 2)
			dim as integer cellType = map(x, y).t
			drawCell(x, y, cellColor(cellType))
		next
	next
end sub

'draw nest heat map
sub drawMapNhm(map() as cell_type)
	for x as integer = 0 to ubound(map, 1)
		for y as integer = 0 to ubound(map, 2)
			dim as integer value = 255 - map(x, y).nhm * 5
			if value < 0 then value = 0
			dim as ulong c = rgb(value, value, value)
			drawCell(x, y, c)
		next
	next
end sub

'set 'count' random locations to type,
'but not to close to border of map, determined by f
'e.g. (rnd * 0.8 + 0.1) => 0.1....0.9 range for f = 0.8
sub setRndPos(map() as cell_type, count as integer, cellType as integer, f as double)
	dim as double f2 = (1 - f) / 2
	for i as integer = 1 to count
		dim as integer x = int((rnd * f + f2) * ubound(map, 1))
		dim as integer y = int((rnd * f + f2) * ubound(map, 2))
		map(x, y).t = cellType
	next
end sub

function getCell(map() as cell_type, x as integer, y as integer) as integer
	if x < lbound(map, 1) then return T_NONE
	if x > ubound(map, 1) then return T_NONE
	if y < lbound(map, 2) then return T_NONE
	if y > ubound(map, 2) then return T_NONE
	return map(x, y).t
end function

'-------------------------------------------------------------------------------

'ant tasks
const FROZEN = 0 'or dead
const SEARCH_FOOD = 1 'random walk?
const GOTO_NEST = 2
const GOTO_FOOD = 3

type ant_type
	dim as integer x, y 'position on map
	dim as integer task
end type

const NUM_ANT = 10
dim as ant_type ant(NUM_ANT - 1)

'smaller then cell
sub drawAnt(x as integer, y as integer, c as ulong)
	line(x * DRAW_SCALE + 1, y * DRAW_SCALE + 1)-_
	step(DRAW_SCALE - 3, DRAW_SCALE - 3), c, bf
end sub

sub drawAnts(ant() as ant_type)
	for i as integer = 0 to ubound(ant)
		dim as ulong c
		select case ant(i).task
		case FROZEN : c = C_DGREY
		case SEARCH_FOOD : c = C_RED
		case GOTO_NEST : c = C_BLUE
		case GOTO_FOOD : c = C_DGREEN
		end select
		drawAnt(ant(i).x, ant(i).y, c)
	next
end sub

'-------------------------------------------------------------------------------

type nest_type
	dim as integer x, y 'position on map
end type

const NUM_NEST = 3 'entrance
dim as nest_type nest(NUM_NEST - 1)

'-------------------------------------------------------------------------------

type move_type
	dim as integer dx, dy
end type

'delta move: up, right, down, left
dim as move_type move(0 to 3) = {(0,-1), (+1,0), (0,+1), (-1,0)}

'-------------------------------------------------------------------------------

randomize timer '7878 'timer

'initialize map
setRndPos(map(), 500, T_OBST, 0.9) 'set obstacles
setRndPos(map(), 5, T_FOOD, 0.7) 'set food positions
'set nest & food heat map to 'undiscovered' / far away
for x as integer = 0 to ubound(map, 1)
	for y as integer = 0 to ubound(map, 2)
		map(x, y).nhm = 99999
		map(x, y).fhm = 99999
	next
next
for i as integer = 0 to ubound(nest) 'set nests
	nest(i).x = int((rnd * 0.6 + 0.2) * MAP_W)
	nest(i).y = int((rnd * 0.6 + 0.2) * MAP_H)
	with map(nest(i).x, nest(i).y)
		.t = T_NEST 'mark on map
		.nhm = 0 'distance to nest is zero
	end with
next

'set ant start position to a nest entrance location
for i as integer = 0 to ubound(ant)
	dim as integer iNest = int(rnd * NUM_NEST)
	ant(i).x = nest(iNest).x
	ant(i).y = nest(iNest).y
	ant(i).task = SEARCH_FOOD
next

dim as integer showNhm = false, showFhm = false
dim as string key
dim as integer i, steps = 0, found = 0, collected = 0
do
	'display stuff
	screenlock
	if showNhm then
		'show nest heat map
		drawMapNhm(map())
	elseif showFhm then
		'show food heat map
	else
		drawMapT(map())
	end if
	drawAnts(ant())
	draw string(10, 10), "<ESC> = exit, <N> nest heat map, <F> food heat map", C_LGREEN
	draw string(10, 30), "Steps: " + str(steps), C_LGREEN
	draw string(10, 50), "Found: " + str(found), C_LGREEN
	draw string(10, 70), "Collected: " + str(collected), C_LGREEN
	for i = 0 to ubound(ant) 'list ant tasks
		draw string(10, 90 + i * 16), str(ant(i).task), C_LGREEN
	next
	screenunlock
	
	'update ant positions and tasks
	for i = 0 to ubound(ant)
		with ant(i)
			select case .task
			case FROZEN
				'nothing
			case SEARCH_FOOD
				dim as integer antdir = int(rnd * 4)
				dim as integer oldx = .x
				dim as integer oldy = .y
				select case antdir
					case 0 : .y -= 1 'up
					case 1 : .x += 1 'right
					case 2 : .y += 1 'down
					case 3 : .x -= 1 'left
				end select
				dim as integer cellValue = getCell(map(), .x, .y)
				if cellValue = T_OBST or cellValue = T_NONE then
					.x = oldx 'reset position
					.y = oldy
				else 'step done
					'get prev. distance to nest
					dim as integer prevNestDist = map(oldx, oldy).nhm
					dim as integer thisNestDist = map(.x, .y).nhm
					if thisNestDist < prevNestDist then
						'implies already visited location & shorter path found, closer to nest
						map(oldx, oldy).nhm = thisNestDist + 1
					else
						map(.x, .y).nhm = prevNestDist + 1
					end if
				end if
				if cellValue = T_FOOD then
					.task = GOTO_NEST
					found += 1
				end if
			case GOTO_NEST
				dim as integer antdir = -1 'invalid direction
				dim as integer bestNestDist = map(.x, .y).nhm 'current position
				dim as integer tryx, tryy
				for i as integer = 0 to 3 'loop directions
					tryx = .x + move(i).dx
					tryy = .y + move(i).dy
					dim as integer cellValue = getCell(map(), tryx, tryy)
					'if cellValue <> T_OBST and cellValue <> T_NONE then 'can go there
						if map(tryx, tryy).nhm < bestNestDist then
							antdir = i
							bestNestDist = map(tryx, tryy).nhm
						end if
					'end if
				next
				if antdir <> -1 then 'update ant position
					.x += move(antdir).dx
					.y += move(antdir).dy
				end if
				'if nest reached, goto_food
				if map(.x, .y).t = T_NEST then
					collected += 1
					.task = GOTO_FOOD
				end if
			case GOTO_FOOD
				'if food found, goto_nest
				'if food gone???, search_food
			end select
		end with
	next
	
	sleep 50,0 'shorter sleep to speed up
	steps += 1
	key = inkey
	if multikey(FB.SC_N) then showNhm = true else showNhm = false
	if multikey(FB.SC_F) then showFhm = true else showFhm = false
loop while not multikey(FB.SC_ESCAPE)
print "End"
getkey()

neil · Post by **neil** » Jan 21, 2024 21:34

@badidea
It took about 20 minutes for all of the ants to find the food source.
The last two ants could have used some help finding a food source.
For a demo, I'm not sure if everyone is going to wait 20 or more minutes for it to finish.
Is there any way you could speed it up?

Langton's ant

Langton's ant

Re: Langton's ant

Re: Langton's ant

Re: Langton's ant

Re: Langton's ant

Re: Langton's ant

Re: Langton's ant

Re: Langton's ant

Re: Langton's ant

Re: Langton's ant

Re: Langton's ant

Re: Langton's ant

Re: Langton's ant

Re: Langton's ant

Re: Langton's ant