71 lines
2.0 KiB
Tcl
71 lines
2.0 KiB
Tcl
package require Tcl 8.5
|
|
proc tcl::mathfunc::randchar {} {
|
|
# A function to select a random character
|
|
set charset "ABCDEFGHIJKLMNOPQRSTUVWXYZ "
|
|
string index $charset [expr {int([string length $charset] * rand())}]
|
|
}
|
|
set target "METHINKS IT IS LIKE A WEASEL"
|
|
set initial [subst [regsub -all . $target {[expr randchar()]}]]
|
|
set MaxMutateRate 0.91
|
|
set C 100
|
|
|
|
# A place-wise equality function defined over two lists (assumed equal length)
|
|
proc fitnessByEquality {target s} {
|
|
set count 0
|
|
foreach c1 $s c2 $target {
|
|
if {$c1 eq $c2} {incr count}
|
|
}
|
|
return [expr {$count / double([llength $target])}]
|
|
}
|
|
# Generate the fitness *ratio* by place-wise equality with the target string
|
|
interp alias {} fitness {} fitnessByEquality [split $target {}]
|
|
|
|
# This generates the converse of the Python version; logically saner naming
|
|
proc mutationRate {individual} {
|
|
global MaxMutateRate
|
|
expr {(1.0-[fitness $individual]) * $MaxMutateRate}
|
|
}
|
|
|
|
# Mutate a string at a particular rate (per character)
|
|
proc mutate {parent rate} {
|
|
foreach c $parent {
|
|
lappend child [expr {rand() <= $rate ? randchar() : $c}]
|
|
}
|
|
return $child
|
|
}
|
|
|
|
# Pretty printer
|
|
proc prettyPrint {iterations parent} {
|
|
puts [format "#%-4i, fitness %5.1f%%, '%s'" $iterations \
|
|
[expr {[fitness $parent]*100}] [join $parent {}]]
|
|
}
|
|
|
|
# The evolutionary algorithm itself
|
|
proc evolve {initialString} {
|
|
global C
|
|
|
|
# Work with the parent as a list; the operations are more efficient
|
|
set parent [split $initialString {}]
|
|
|
|
for {set iterations 0} {[fitness $parent] < 1} {incr iterations} {
|
|
set rate [mutationRate $parent]
|
|
|
|
if {$iterations % 100 == 0} {
|
|
prettyPrint $iterations $parent
|
|
}
|
|
|
|
set copies [list [list $parent [fitness $parent]]]
|
|
for {set i 0} {$i < $C} {incr i} {
|
|
lappend copies [list \
|
|
[set copy [mutate $parent $rate]] [fitness $copy]]
|
|
}
|
|
set parent [lindex [lsort -real -decreasing -index 1 $copies] 0 0]
|
|
}
|
|
puts ""
|
|
prettyPrint $iterations $parent
|
|
|
|
return [join $parent {}]
|
|
}
|
|
|
|
evolve $initial
|