"Genetic Algorithm Tutorial" only the source code

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
D.J.Peters
Posts: 7852
Joined: May 28, 2005 3:28

"Genetic Algorithm Tutorial" only the source code

Postby D.J.Peters » Jan 24, 2009 6:52

http://www.ai-junkie.com/index.html

Code: Select all

' program Ga_Tutorial:
' code to illustrate the use of a genetic algorithm
' to solve the problem described at
' http://www.ai-junkie.com/ga/intro/gat1.html
'
' by Mat Buckland aka fupp
' ported to FreeBasic by Detlef Jürgen Peters (aka Joshy)

const as single  CROSSOVER_RATE = 0.7
const as single  MUTATION_RATE  = 0.001
const as integer POP_SIZE       = 40 ' must be an even number
const as integer CHROMO_LENGTH  = 200
const as integer GENE_LENGTH    = 4
const as integer MAX_ALLOWABLE_GENERATIONS = 200

' define a data structure which will define a chromosome
type TChromo
  bits    as string
  fitness as single
end type

' global storage for our population of chromosomes.
dim shared g_Population(POP_SIZE-1) as TChromo

' Initializes chromosone
function Chromo(bits as string = "",fitness as single = 0.0) as TChromo
  dim result as TChromo
  result.bits    = bits
  result.fitness = fitness
  return result
end function

' This function returns a string of random 1s and 0s of the desired length.
function GetRandomBits(length as integer) as string
  dim i as integer
  dim result as string
  result = space(length)

  for i = 0 to length-1
    if (rnd > 0.5) then
      result[i]= asc("1")
    else
      result[i]= asc("0")
    end if
  next
  return result
end function

' converts a binary string into a decimal integer
function BinToDec(bits as string) as integer
  dim i as integer, value_to_add as integer
  dim result as integer = 0
  value_to_add = 1

  for i = len(bits)-1 to 0 step -1
    if bits[i] = asc("1") then
      result = result + value_to_add
    end if
    value_to_add = value_to_add * 2
  next
  return result
end function

' Given a chromosome this function will step through the genes one at a time and insert
' the decimal values of each gene (which follow the operator - number - operator rule)
' into a buffer. Returns the number of elements in the buffer
function ParseBits(bits as string, buffer() as integer) as integer
  dim i         as integer
  dim cBuff     as integer
  dim this_gene as integer
  dim bOperator as integer ' boolean

  ' counter for buffer position
  cBuff= 0

  ' step through bits a gene at a time until end and store decimal values
  ' of valid operators and numbers. Don't forget we are looking for operator -
  ' number - operator - number and so on...
  ' We ignore the unused genes 1111 and 1110

  ' flag to determine if we are looking for an operator or a number
  bOperator = -1 'true

  i=1
  while i <= CHROMO_LENGTH
    ' convert the current gene to decimal
    this_gene = BinToDec(mid(bits, i, GENE_LENGTH))
    ' find a gene which represents an operator
    if bOperator then
      if ( (this_gene >= 10) and (this_gene <= 13) ) then
        bOperator=0 ' false
        buffer(cBuff)= this_gene
        cBuff= cBuff + 1
      end if
    else
      ' find a gene which represents a number
      if (this_gene <= 9) then
        bOperator=-1 ' true
        buffer(cBuff) = this_gene
        cBuff = cBuff + 1
      end if
    end if
    i = i + GENE_LENGTH
  wend ' next gene

  ' now we have to run through buffer to see if a possible divide by zero
  ' is included and delete it. (ie a '/' followed by a '0'). We take an easy
  ' way out here and just change the '/' to a '+'. This will not effect the
  ' evolution of the solution

  for i= 0 to cBuff-1
    if ( (buffer(i) = 13) and (buffer(i+1) = 0) ) then
      buffer(i) = 10
    end if
  next

  return cBuff
end function

' given a string of bits and a target value
' this function will calculate its representation
' and return a fitness score accordingly
function AssignFitness(bits as string,target_value as single) as single
  ' holds decimal values of gene sequence
  dim buffer((CHROMO_LENGTH\GENE_LENGTH)-1) as integer
  dim i            as integer
  dim num_elements as integer

  num_elements = ParseBits(bits, buffer())

  ' ok, we have a buffer filled with valid values of:
  ' operator - number - operator - number..
  ' now we calculate what this represents.

  dim result as single = 0.0

  i = 0
  while i < (num_elements-1)
    select case buffer(i)
      case 10: result= result + buffer(i+1)
      case 11: result= result - buffer(i+1)
      case 12: result= result * buffer(i+1)
      case 13: result= result / buffer(i+1)
    end select
    i = i + 2
  wend

  ' Now we calculate the fitness.
  ' First check to see if a solution has been found
  ' and assign an arbitarily high fitness score if this is so.
  if (result = target_value) then
    result = 999
  else
    result = 1.0 / abs(target_value - result)
  end if
   return result
end function

' given an integer this function outputs its meaning to the screen
sub PrintGeneSymbol(value as integer)
  if (value < 10 ) then
    print value & " ";
  else
    select case value
      case 10: print "+";
      case 11: print "-";
      case 12: print "*";
      case 13: print "/";
    end select
    print " ";
  end if
end sub

' decodes and prints a chromo to screen
sub PrintChromo(bits as string)

  ' holds decimal values of gene sequence
  dim buffer((CHROMO_LENGTH\GENE_LENGTH)-1) as integer
  dim i as integer
  dim num_elements as integer

  ' parse the bit string
  num_elements = ParseBits(bits, buffer())

  ' now we have the buffer step through and print values
  for i = 0 to num_elements-1
    PrintGeneSymbol(buffer(i))
  next
  print
end sub

' Mutates a chromosomes bits dependent on the MUTATION_RATE
sub Mutate(bits as string)
  dim i as integer
  for i = 0 to len(bits)-1
    if (rnd < MUTATION_RATE) then
      if bits[i] = asc("1") then
        bits[i] = asc("0")
      else
        bits[i] = asc("1")
      end if
    end if
  next
end sub

' selects a chromosome from the population via roulette wheel selection
function Roulette(total_fitness as single) as string
  dim Slice as single
  dim FitnessSoFar as single
  dim i as integer
  dim result as string = ""

  ' generate a random number between 0 & total fitness count
  Slice = rnd * total_fitness

  ' go through the chromosones adding up the fitness so far
  FitnessSoFar=0

  for i = 0 to POP_SIZE-1
    FitnessSoFar = FitnessSoFar + g_Population(i).fitness
    ' if the fitness so far > random number return the chromo at this point
    if (FitnessSoFar >= Slice) then
       return g_Population(i).bits
    end if
  next
  return result
end function

'
' main
'
dim Target       as single
dim TotalFitness as single
dim i            as integer
dim GenerationsRequiredToFindASolution as integer
dim cPop      as integer
dim crossover as integer
dim bFound    as integer ' boolean
dim temp(POP_SIZE-1) as TChromo
dim bits1 as string
dim bits2 as string
dim t1    as string
dim t2    as string

print "press [ctrl]+[c] to abort"
print
while 1 ' run endless
  ' seed the random number generator
  Randomize(timer)
  print
  ' get a target number from the user. (no error checking)
  Input "Input a target number: "; Target
  ' first create a random population
  for i = 0 to POP_SIZE-1
    g_Population(i) = Chromo(GetRandomBits(CHROMO_LENGTH))
  next

  GenerationsRequiredToFindASolution=0

  ' we will set this flag if a solution has been found
  bFound = 0 ' false

  ' enter the main GA loop
  while (bFound=0)
    ' this is used during roulette wheel sampling
    TotalFitness = 0

    ' test and update the fitness of the population.
    for i = 0 to POP_SIZE-1
      g_Population(i).fitness = AssignFitness(g_Population(i).bits, Target)
      TotalFitness = TotalFitness + g_Population(i).fitness
    next

    ' check to see if we have found any solutions (fitness will be 999)
    for i = 0 to POP_SIZE-1
      if (g_Population(i).fitness = 999) then
        print "Solution found in " & GenerationsRequiredToFindASolution & " generations!"
        PrintChromo(g_Population(i).bits)
        bFound =-1 ' true
        exit for
      end if
    next
    if bFound then exit while

    ' create a new population by roulette wheel sampling of the
    ' old population. Including crossover and mutation.
    cPop= 0

    ' loop until we have created POP_SIZE new chromosomes
    while (cPop < POP_SIZE)
      ' we are going to create the new population by grabbing members
      ' of the old population 2 at a time via roulette wheel selection.
      bits1=Roulette(TotalFitness)
      bits2=Roulette(TotalFitness)

      ' now add crossover if required
      if (rnd < CROSSOVER_RATE) then
        ' create a random crossover point
        crossover = int(rnd*CHROMO_LENGTH)+1
        t1=mid(bits1, 1, crossover) & mid(bits2, crossover+1, CHROMO_LENGTH)
        t2=mid(bits2, 1, crossover) & mid(bits1, crossover+1, CHROMO_LENGTH)
        'assert(length(t1) = CHROMO_LENGTH)
        'assert(length(t2) = CHROMO_LENGTH)
        bits1= t1
        bits2= t2
      end if

      ' now mutate
      Mutate(bits1)
      Mutate(bits2)

      ' now add to new population
      temp(cPop)= Chromo(bits1)
      cPop= cPop + 1
      temp(cPop)= Chromo(bits2)
      cPop= cPop + 1
    wend

    ' copy temp population into main population array
    for i = 0 to POP_SIZE-1
      g_Population(i)= temp(i)
    next
    GenerationsRequiredToFindASolution+=1

    ' exit app if no solution found within the maximum
    ' allowable number of generations
    if (GenerationsRequiredToFindASolution > MAX_ALLOWABLE_GENERATIONS) then
      print "No solutions found this run"
      print
      bFound=-1 ' true
    end if
  wend
wend
Mentat
Posts: 332
Joined: Oct 27, 2007 15:23
Location: NC, US
Contact:

Postby Mentat » Jan 25, 2009 3:00

Cool. I'm a GA fan.

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 1 guest