Ok, final update, I think. The project is getting boring.
as an alternative for the random walk during food search.
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 - done
'- switch to different location when the food runs out - done
'- pick up food trace during random walk - done
'- optimize the path - todo
'TODO:
'- teleport ants to other nest when entering nest, after delay (based on nest distance)
#include "fbgfx.bi"
const NUM_ANT = 30
const NUM_NEST = 3 'nest entrances
const NUM_FOOD = 10
const NUM_OBST = 1000 'obstacles / rocks
const MIN_FOOD_UNITS = 10
const MAX_FOOD_UNITS = 50
const MAX_HM = 500 'for heat map
'lower for faster decay of path
'but limits max path length as well
'and it can cause food paths to farther away source to disappear, due to preffred for nearby sources
const WALK_RANDOM = 0
const WALK_BC2 = 1
const WALK_LANGTON = 2
const WALK_METHOD = WALK_LANGTON 'select random walk algorithm, from list above
#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_WHITE = hRGB(&hFFF) '
const as ulong C_BLACK = hRGB(&h000) 'nest
const as ulong C_YELLOW = hRGB(&hFF0) 'food
const as ulong C_RED = hRGB(&hF00) 'ant random food search
const as ulong C_LGREEN = hRGB(&h0F0) 'text
const as ulong C_DGREEN = hRGB(&h080) 'ant to food
const as ulong C_BLUE = hRGB(&h22F) 'ant to nest
const as ulong C_BROWN = hRGB(&h532) 'dirt
const as ulong C_LGREY = hRGB(&h777) 'rock / obstacle
const as ulong C_DGREY = hRGB(&h333) 'dead ant
'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
dim as integer fu 'food units
dim as integer bw 'black or white, for langtons ant algoritm
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
'-------------------------------------------------------------------------------
type move_type
dim as integer dx, dy
end type
'delta move: up, right, down, left
dim shared as move_type move(0 to 3) = {(0,-1), (+1,0), (0,+1), (-1,0)}
'-------------------------------------------------------------------------------
'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 dir_ '0 = up, 1 = right, 2 = down, 3 = left
dim as integer task
declare sub turn(rirection as integer)
end type
'-1 = trun left, +1 turn right
sub ant_type.turn(turnDir as integer)
select case turnDir
case -1 'left
this.dir_ -= 1
if this.dir_ < 0 then this.dir_ = 3
case +1 'right
this.dir_ += 1
if this.dir_ > 3 then this.dir_ = 0
end select
end sub
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
'-------------------------------------------------------------------------------
'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
if cellType = T_FOOD then
'less bright is less food, range 100...255
dim as integer foodUnits = map(x, y).fu
dim as integer intensity = 100 + (155 * foodUnits) / MAX_FOOD_UNITS
dim as ulong c = rgb(intensity, intensity, 0)
drawCell(x, y, c)
else
drawCell(x, y, cellColor(cellType))
end if
next
next
end sub
const MIN_INTENSITY = 20 'minimum visible on screen?
'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 = map(x, y).nhm
dim as ulong c = 0
if value <> MAX_HM then
dim as integer intensity = 255 - value
if intensity < MIN_INTENSITY then intensity = MIN_INTENSITY
c = rgb(intensity, intensity, intensity)
end if
drawCell(x, y, c)
next
next
end sub
'draw food heat map
sub drawMapFhm(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 = map(x, y).fhm
dim as ulong c = 0
if value < MAX_HM then
dim as integer intensity = 255 - value
if intensity < MIN_INTENSITY then intensity = MIN_INTENSITY
c = rgb(intensity, intensity, intensity)
end if
drawCell(x, y, c)
next
next
end sub
'draw food heat map
sub drawMapLbw(map() as cell_type)
for x as integer = 0 to ubound(map, 1)
for y as integer = 0 to ubound(map, 2)
dim as ulong c = C_WHITE
if map(x, y).bw = 1 then c = C_BLACK
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
'can go there?
function canWalk(map() as cell_type, x as integer, y as integer) as integer
if x < lbound(map, 1) then return false
if x > ubound(map, 1) then return false
if y < lbound(map, 2) then return false
if y > ubound(map, 2) then return false
return iif(map(x, y).t = T_OBST, false, true)
'dim as integer cellValue = getCell(map(), x, y)
'return iif(cellValue <> T_OBST and cellValue <> T_NONE, true, false)
end function
sub walk(map() as cell_type, byref ant as ant_type)
select case WALK_METHOD
case WALK_RANDOM
dim as integer antdir = int(rnd * 4) 'previous direction 'ant.dir_' irrelevant
case WALK_BC2
'BasicCoder2: 50% likely step forward, 25% veer left and 25% veer right
dim as integer selection = int(rnd * 4)
select case selection
case 0, 1 'forward
'ant.dir_ unchanged
case 2 'turn left
ant.turn(-1)
case 3 'turn right
ant.turn(+1)
end select
case WALK_LANGTON
'At a white square, turn 90° clockwise, flip the color of the square, move forward one unit
'At a black square, turn 90° counter-clockwise, flip the color of the square, move forward one unit
'With odification: If blocked, do turn, don't flip (white = 0, black = 1)
if map(ant.x, ant.y).bw = 0 then
ant.turn(+1) 'turn right
else
ant.turn(-1) 'turn left
end if
if canWalk(map(), ant.x + move(ant.dir_).dx, ant.y + move(ant.dir_).dy) then
map(ant.x, ant.y).bw xor= 1 'flip
end if
end select
ant.x += move(ant.dir_).dx
ant.y += move(ant.dir_).dy
end sub
'-------------------------------------------------------------------------------
type nest_type
dim as integer x, y 'position on map
end type
sub setNestPos(map() as cell_type, nest() as nest_type, i as integer) 'i = next index
tryAgain:
dim as integer x = int((rnd * 0.6 + 0.2) * MAP_W)
dim as integer y = int((rnd * 0.6 + 0.2) * MAP_H)
if map(x, y).t <> T_DIRT then goto tryAgain
nest(i).x = x
nest(i).y = y
map(x, y).t = T_NEST 'mark on map
map(x, y).nhm = 0 'distance to nest is zero
end sub
dim as nest_type nest(NUM_NEST - 1)
'-------------------------------------------------------------------------------
sub setFoodRnd(map() as cell_type)
tryAgain:
dim as integer x = int((rnd * 0.8 + 0.1) * MAP_W)
dim as integer y = int((rnd * 0.8 + 0.1) * MAP_H)
if map(x, y).t <> T_DIRT then goto tryAgain 'don't erase other stuff
map(x, y).t = T_FOOD
map(x, y).fhm = 0 'distance to food is zero
map(x, y).fu = int(rnd * (MAX_FOOD_UNITS - MIN_FOOD_UNITS)) + MIN_FOOD_UNITS
end sub
sub updateFood(map() as cell_type, x as integer, y as integer, byref found as integer)
found += 1
map(x, y).fu -= 1 'reduce food unit count
if map(x, y).fu = 0 then 'food depleted
map(x, y).fhm = MAX_HM
map(x, y).t = T_DIRT
setFoodRnd(map()) 'add a new food location
end if
end sub
'-------------------------------------------------------------------------------
randomize timer '7878 'timer
'set obstacles on map
setRndPos(map(), NUM_OBST, T_OBST, 0.95)
'set heat maps: nest & food 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 = MAX_HM
map(x, y).fhm = MAX_HM
next
next
'set food positions
for i as integer = 0 to NUM_FOOD - 1
setFoodRnd(map())
next
'set nest locations
for i as integer = 0 to ubound(nest)
setNestPos(map(), nest(), i)
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
'main loop
dim as integer showNhm = false, showFhm = false, showLbw = false
dim as string key
dim as integer steps = 0, found = 0, collected = 0
do
'display stuff
screenlock
if showNhm then
drawMapNhm(map()) 'show nest heat map
elseif showFhm then
drawMapFhm(map()) 'show food heat map
elseif showLbw then
drawMapLbw(map()) 'show langtons black white color
else
drawMapT(map()) 'show normal surface map
end if
drawAnts(ant())
draw string(10, 10), "<ESC> = exit", C_LGREEN
draw string(10, 30), "<N> nest heat map", C_LGREEN
draw string(10, 50), "<F> food heat map", C_LGREEN
draw string(10, 70), "<R> relocate a nest entrance", C_LGREEN
draw string(10, 90), "<L> Langton color map", C_LGREEN
draw string(10, 130), "Steps: " + str(steps), C_LGREEN
draw string(10, 150), "Found: " + str(found), C_LGREEN
draw string(10, 170), "Collected: " + str(collected), C_LGREEN
screenunlock
'fade out food trails
for x as integer = 0 to ubound(map, 1)
for y as integer = 0 to ubound(map, 2)
'fhm: 0 = food, MAX_HM = no trail
if map(x, y).fhm < MAX_HM then 'filter out most cases
if map(x, y).fhm > 0 then
map(x, y).fhm += 1
end if
end if
next
next
'fade out nest heat map
if steps mod 10 = 0 then
for x as integer = 0 to ubound(map, 1)
for y as integer = 0 to ubound(map, 2)
'nhm: 0 = nest, MAX_HM = nothing
if map(x, y).nhm < MAX_HM then
if map(x, y).nhm > 0 then
map(x, y).nhm += 1
end if
end if
next
next
end if
'update ant positions and tasks
for i as integer = 0 to ubound(ant)
with ant(i)
select case .task
case FROZEN
'nothing
'-------------------------------------------------------------------
case SEARCH_FOOD 'red ant
'-------------------------------------------------------------------
dim as integer oldx = .x
dim as integer oldy = .y
walk(map(), ant(i)) 'updates .x, .y
if canWalk(map(), .x, .y) then
dim as integer prevNestDist = map(oldx, oldy).nhm 'get prev. distance to nest
dim as integer thisNestDist = map(.x, .y).nhm
if thisNestDist < prevNestDist then
'implies already visited location & shorter path found, closer to nest
if map(oldx, oldy).nhm > 0 then map(oldx, oldy).nhm = thisNestDist + 1
else
'normal step, further away from nest
if map(.x, .y).nhm > 0 then map(.x, .y).nhm = prevNestDist + 1
end if
else 'reset position
.x = oldx
.y = oldy
end if
'check for food trail, follow if found, gather food if on food
if map(.x, .y).fhm < MAX_HM then
if map(.x, .y).t = T_FOOD then 'on food
.task = GOTO_NEST
updateFood(map(), .x, .y, found)
else
.task = GOTO_FOOD
end if
end if
'-------------------------------------------------------------------
case GOTO_NEST 'blue ant
'-------------------------------------------------------------------
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
if canWalk(map(), tryx, tryy) then
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
dim as integer prevFoodDist = map(.x, .y).fhm 'previous distance to food
.x += move(antdir).dx
.y += move(antdir).dy
if map(.x, .y).fhm > 0 then
map(.x, .y).fhm = prevFoodDist + 1 '1 step further away from food now
end if
else
'lost path to nest, mark spot as 'not so good'
if map(.x, .y).nhm < MAX_HM then
if map(.x, .y).nhm > 0 then map(.x, .y).nhm += 1
else
'totally lost
'.task = FROZEN 'problem! Do random move?
.task = SEARCH_FOOD 'discard current food unit, find new food location
end if
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 'green ant
'-------------------------------------------------------------------
dim as integer antdir = -1 'invalid direction
dim as integer bestFoodDist = map(.x, .y).fhm '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
if canWalk(map(), tryx, tryy) then
if map(tryx, tryy).fhm < bestFoodDist then
antdir = i
bestFoodDist = map(tryx, tryy).fhm
end if
end if
next
if antdir <> -1 then 'update ant position
dim as integer prevNestDist = map(.x, .y).nhm 'previous distance to nest
.x += move(antdir).dx
.y += move(antdir).dy
if map(.x, .y).nhm > 0 then 'don't delete nhm of a nest
map(.x, .y).nhm = prevNestDist + 1 '1 step further away from nest now
end if
else
'stuck, path/food lost, do random walk search
.task = SEARCH_FOOD
'map(.x, .y).fhm = MAX_HM 'destroy food trail (last part)
end if
if map(.x, .y).t = T_FOOD then
.task = GOTO_NEST
updateFood(map(), .x, .y, found)
end if
end select
end with
next
sleep 50,0 'shorter sleep to speed up
steps += 1
key = inkey
if ucase(key) = "R" then 'move a nest entrance
dim as integer i = int(rnd * NUM_NEST)
with map(nest(i).x, nest(i).y) 'erase entrance
.t = T_DIRT 'into dirt
.nhm = MAX_HM 'distance to nest max value
end with
setNestPos(map(), nest(), i) 'assign new location
end if
if multikey(FB.SC_N) then showNhm = true else showNhm = false
if multikey(FB.SC_F) then showFhm = true else showFhm = false
if multikey(FB.SC_L) then showLbw = true else showLbw = false
loop while not multikey(FB.SC_ESCAPE)
print "End"
getkey()
