56 lines
1.6 KiB
Tcl
56 lines
1.6 KiB
Tcl
package require Tcl 8.5
|
|
|
|
# A function to select a random character from an argument string
|
|
proc tcl::mathfunc::randchar s {
|
|
string index $s [expr {int([string length $s]*rand())}]
|
|
}
|
|
|
|
# Set up the initial variables
|
|
set target "METHINKS IT IS LIKE A WEASEL"
|
|
set charset "ABCDEFGHIJKLMNOPQRSTUVWXYZ "
|
|
set parent [subst [regsub -all . $target {[expr {randchar($charset)}]}]]
|
|
set MaxMutateRate 0.91
|
|
set C 100
|
|
|
|
# Work with parent and target as lists of characters so iteration is more efficient
|
|
set target [split $target {}]
|
|
set parent [split $parent {}]
|
|
|
|
# Generate the fitness *ratio*
|
|
proc fitness s {
|
|
global target
|
|
set count 0
|
|
foreach c1 $s c2 $target {
|
|
if {$c1 eq $c2} {incr count}
|
|
}
|
|
return [expr {$count/double([llength $target])}]
|
|
}
|
|
# This generates the converse of the Python version; logically saner naming
|
|
proc mutateRate {parent} {
|
|
expr {(1.0-[fitness $parent]) * $::MaxMutateRate}
|
|
}
|
|
proc mutate {rate} {
|
|
global charset parent
|
|
foreach c $parent {
|
|
lappend result [expr {rand() <= $rate ? randchar($charset) : $c}]
|
|
}
|
|
return $result
|
|
}
|
|
proc que {} {
|
|
global iterations parent
|
|
puts [format "#%-4i, fitness %4.1f%%, '%s'" \
|
|
$iterations [expr {[fitness $parent]*100}] [join $parent {}]]
|
|
}
|
|
|
|
while {$parent ne $target} {
|
|
set rate [mutateRate $parent]
|
|
if {!([incr iterations] % 100)} que
|
|
set copies [list [list $parent [fitness $parent]]]
|
|
for {set i 0} {$i < $C} {incr i} {
|
|
lappend copies [list [set copy [mutate $rate]] [fitness $copy]]
|
|
}
|
|
set parent [lindex [lsort -real -decreasing -index 1 $copies] 0 0]
|
|
}
|
|
puts ""
|
|
que
|