10-06-2017, 07:03 AM
# genetic_alg.tcl --
#
# Package for implementing simple genetic algorithms
# (Tcl-only version)
#
# Notes:
# This package is shamelessly modelled after a publically
# available program by Scott Robert Ladd (http://coyotegulch.com)
#
# Version information:
# version 0.1: initial implementation, february 2002
package provide GeneticAlgorithms 0.1
namespace eval ::GeneticAlgorithms {
variable crossover 0.5
variable mutation 0.1
variable elitism 1
variable quadweight 0
variable best_guess {}
variable population {}
variable child_pop {}
namespace export setting optimise optimiseStep
# limitvalue
# Limit the argument between two bounds
#
# Arguments:
# value New value (if not present, return current value)
# minimum Minimum bound
# maximum Maximum bound
#
# Result:
# Value or one of the bounds
#
proc limitvalue {value minimum maximum} {
if { $value < $minimum } {
return $minimum
}
if { $value > $maximum } {
return $maximum
}
return $value
}
# setting
# Set/get the settings
#
# Arguments:
# name Name of a variable to set or get
# value New value (if not present, return current value)
#
# Result:
# New value for given variable
#
# Side effects:
# Sets given variable to new value
#
proc setting {name {value NONE} } {
variable $name
if { $value != "NONE" } {
switch -- $name {
"crossover" { set $name [limitvalue $value 0.0 1.0] }
"mutation" { set $name [limitvalue $value 0.0 1.0] }
"elitism" { set $name [expr $value!=0] }
"quadweight" { set $name [expr $value!=0] }
default { error "setting: unknown parameter $name" }
}
set $name
}
}
# optimise --
# Optimise the given function using a genetic algorithm
#
# Arguments:
# pop_size Size of the population
# max_gen Maximum number of generations
# no_genes Number of "genes" - degrees of freedoms
# fitness Function of the degrees of freedom, returns the fitness
# of the solution (as a non-negative number!)
#
# Result:
# Best guess of degrees of freedom, as a list
#
proc optimise { pop_size max_gen no_genes fitness } {
variable best_guess
optimiseInit $pop_size $no_genes
for { set i 0 } { $i < $max_gen } { incr i } {
optimiseStep $pop_size $no_genes $fitness
puts "$best_guess - [$fitness $best_guess]"
}
return $best_guess
}
# optimiseInit --
# Initialise the population
#
# Arguments:
# pop_size Size of the population
# no_genes Number of "genes" - degrees of freedoms
#
# Result:
# None
#
# Side effects:
# Initialised list variable population
#
proc optimiseInit { pop_size no_genes } {
variable population
variable child_pop
set population {}
for { set i 0 } { $i < $pop_size } { incr i } {
set member {}
for { set j 0 } { $j < $no_genes } { incr j } {
lappend member [expr {int(2147483000.0*rand())}]
}
lappend population $member
}
set child_pop $population
}
# optimiseStep --
# Perform a single step in the optimisation
#
# Arguments:
# pop_size Size of the population
# no_genes Number of "genes" - degrees of freedoms
# fitness Function for determining the fitness
#
# Result:
# None
#
# Side effects:
# New population, best_guess set
#
proc optimiseStep { pop_size no_genes fitness } {
variable population
variable child_pop
variable best_guess
variable mutation
variable crossover
variable quadweight
variable elitism
#
# Copy the child population
#
set population $child_pop
#
# Determine the fitness per member
#
set high_fit -1
set tot_fit 0.0
set pop_fit {}
foreach member $population {
set fit [eval $fitness $member]
if { $high_fit < $fit } {
set high_fit $fit
set best_guess $member
}
lappend pop_fit $fit
set tot_fit [expr {$tot_fit+$fit}]
}
#
# Scale the fitness (quadratic weight)
#
# PM
#
# Elitism: keep the best in any case
#
set child_pop {}
set no_child $pop_size
if { $elitism } {
lappend child_pop $best_guess
incr no_child -1
}
#
# Breed the children
#
for { set i 0 } { $i < $no_child } { incr i } {
set selection [expr {$tot_fit*rand()}]
set father 0
set father_fit [lindex $pop_fit $father]
while { $selection > $father_fit } {
set selection [expr {$selection-$father_fit}]
incr father
set father_fit [lindex $pop_fit $father]
}
set selection [expr {$tot_fit*rand()}]
set mother 0
set mother_fit [lindex $pop_fit $mother]
while { $selection > $mother_fit } {
set selection [expr {$selection-$mother_fit}]
incr mother
set mother_fit [lindex $pop_fit $mother]
}
set child [combineGenes [lindex $population $mother] \
[lindex $population $father] ]
set child [mutateGenes $child]
lappend child_pop $child
}
#puts $population
#puts $pop_fit
}
# combineGenes --
# Combine the genes of the two parents (using cross-over)
#
# Arguments:
# mother Genes of the first parent
# father Genes of the second parent
#
# Result:
# Genes of the child
#
proc combineGenes { mother father } {
variable crossover
set all_bits_set -2147483647
set child {}
foreach first $mother second $father {
set bit_no [expr int(32.0*rand())]
set bitmask [expr {($all_bits_set>>$bit_no)<<$bit_no}]
set newgene [expr {$first&$bitmask $second& $bitmask}]
lappend child $newgene
}
return $child
}
# mutateGenes --
# Mutate the genes of a child (flip a bit)
#
# Arguments:
# child Genes of the child to be mutated
#
# Result:
# Mutated genes
#
proc mutateGenes { child } {
variable mutation
set newgenes {}
foreach gene $child {
if { [expr {rand()}] < $mutation } {
set bit_no [expr {int(32.0*rand())}]
set bitmask [expr {1<<$bit_no}]
set bitset [expr {($gene&$bitmask) != 0}]
if { $bitset } {
set newgene [expr {$gene& $bitmask}]
} else {
set newgene [expr {$gene $bitmask}]
}
} else {
set newgene $gene
}
lappend newgenes $newgene
}
return $newgenes
}
} ;# End of namespace
#namespace import ::GeneticAlgorithms::*
proc testFunc { var } {
expr {1.0-abs($var/2147483647.0-0.5)}
}
puts [::GeneticAlgorithms::optimise 100 40 1 testFunc]