aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

update

Browse source
This commit is contained in:
Ingy döt Net 2013-06-05 21:47:54 +00:00
parent 1f1ad49427
commit 6f050a029e
2496 changed files with 37609 additions and 3031 deletions
Download patch file Download diff file Expand all files Collapse all files

18
Task/Evolutionary-algorithm/D/evolutionary-algorithm.d Normal file
View file

@ -0,0 +1,18 @@
import std.stdio, std.random, std.algorithm, std.range, std.ascii;
enum target = "METHINKS IT IS LIKE A WEASEL"d;
enum C = 100; // Number of children in each generation.
enum P = 0.05; // Mutation probability.
enum fitness = (dchar[] s) => target.zip(s).count!q{ a[0] != a[1] };
dchar rnd() { return (uppercase ~ " ")[uniform(0, $)]; }
enum mut= (dchar[] s) => s.map!(a=> uniform(0,1.) < P ? rnd : a).array;
void main() {
auto parent = target.length.iota.map!(_ => rnd).array;
for (auto gen = 1; parent != target; gen++) {
//parent = parent.repeat(C).map!mut.array.max!(s => s.fitness);
parent = parent.repeat(C).map!mut.array
.minPos!((a, b) => a.fitness < b.fitness)[0];
writefln("Gen %2d, dist=%2d: %s", gen, parent.fitness, parent);
}
}

2
Task/Evolutionary-algorithm/Perl-6/evolutionary-algorithm.pl6
View file

@ -10,4 +10,4 @@ loop (
my $parent = alphabet.roll(target.chars).join;
$parent ne target;
$parent = max :by(&fitness), mutate($parent) xx C
) { printf "%6d: '%s' %2d\n", (state $)++, $parent, fitness $parent }
) { printf "%6d: '%s'\n", (state $)++, $parent }

32
Task/Evolutionary-algorithm/Prolog/evolutionary-algorithm.pro Normal file
View file

@ -0,0 +1,32 @@
target("METHINKS IT IS LIKE A WEASEL").
rndAlpha(64, 32). % Generate a single random character
rndAlpha(P, P). % 32 is a space, and 65->90 are upper case
rndAlpha(Ch) :- random(N), P is truncate(64+(N*27)), !, rndAlpha(P, Ch).
rndTxt(0, []). % Generate some random text (fixed length)
rndTxt(Len, [H|T]) :- succ(L, Len), rndAlpha(H), !, rndTxt(L, T).
score([], [], Score, Score). % Score a generated mutation (count diffs)
score([Ht|Tt], [Ht|Tp], C, Score) :- !, score(Tt, Tp, C, Score).
score([_|Tt], [_|Tp], C, Score) :- succ(C, N), !, score(Tt, Tp, N, Score).
score(Txt, Score, Target) :- !, score(Target, Txt, 0, Score).
mutate(_, [], []). % mutate(Probability, Input, Output)
mutate(P, [H|Txt], [H|Mut]) :- random(R), R < P, !, mutate(P, Txt, Mut).
mutate(P, [_|Txt], [M|Mut]) :- rndAlpha(M), !, mutate(P, Txt, Mut).
weasel(Tries, _, _, mutation(0, Result)) :- % No differences=success
format('~w~4|:~w~3| - ~s\n', [Tries, 0, Result]).
weasel(Tries, Chance, Target, mutation(S, Value)) :- % output progress
format('~w~4|:~w~3| - ~s\n', [Tries, S, Value]), !, % and call again
weasel(Tries, Chance, Target, Value).
weasel(Tries, Chance, Target, Start) :-
findall(mutation(S,M), % Generate 30 mutations, select the best.
(between(1, 30, _), mutate(Chance, Start, M), score(M,S,Target)),
Mutations), % List of 30 mutations and their scores
sort(Mutations, [Best|_]), succ(Tries, N),
!, weasel(N, Chance, Target, Best).
weasel :- % Chance->probability for a mutation, T=Target, Start=initial text
target(T), length(T, Len), rndTxt(Len, Start), Chance is 1 - (1/(Len+1)),
!, weasel(0, Chance, T, Start).

87
Task/Evolutionary-algorithm/REXX/evolutionary-algorithm-1.rexx
View file

@ -1,54 +1,35 @@
/* Weasel.rex - Me thinks thou art a weasel. - G,M.D. - 2/25/2011 */
arg C M
/* C is the number of children parent produces each generation. */
/* M is the mutation rate of each gene (character) */
/*REXX program demonstrates an evolutionary algorithm (using mutation).*/
parse arg children MR seed . /*get options (maybe) from C.L. */
if children=='' then children = 10 /*# of children produced each gen*/
if MR =='' then MR = '4%' /*the char Mutation Rate each gen*/
if right(MR,1)=='%' then MR=strip(MR,,'%')/100 /*expressed as %? Adjust*/
if seed\=='' then call random ,,seed /*allow the runs to be repeatable*/
abc = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ ' ; Labc=length(abc)
target= 'METHINKS IT IS LIKE A WEASEL' ; Ltar=length(target)
parent= mutate( left('',Ltar), 1) /*gen rand str,same length as tar*/
say center('target string',Ltar,'─') "children" 'mutationRate'
say target center(children,8) center((MR*100/1)'%',12) ; say
say center('new string',Ltar,'─') "closeness" 'generation'
call initialize
generation = 0
do until parent = target
most_fitness = fitness(parent)
most_fit = parent
do C
child = mutate(parent, M)
child_fitness = fitness(child)
if child_fitness > most_fitness then
do
most_fitness = child_fitness
most_fit = child
say "Generation" generation": most fit='"most_fit"', fitness="left(most_fitness,4)
end
end
parent = most_fit
generation = generation + 1
end
exit
initialize:
target = "METHINKS IT IS LIKE A WEASEL"
alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ "
c_length_target = length(target)
parent = mutate(copies(" ", c_length_target), 1.0)
do i = 1 to c_length_target
target_ch.i = substr(target,i,1)
end
return
fitness: procedure expose target_ch. c_length_target
arg parm_string
fitness = 0
do i_target = 1 to c_length_target
if substr(parm_string,i_target,1) = target_ch.i_target then
fitness = fitness + 1
end
return fitness
mutate:procedure expose alphabet
arg string, parm_mutation_rate
result = ""
do istr = 1 to length(string)
if random(1,1000)/1000 <= parm_mutation_rate then
result = result || substr(alphabet,random(1,length(alphabet)),1)
else
result = result || substr(string,istr,1)
end
return result
do gen=0 until parent==target; close=fitness(parent)
almost=parent
do children; child=mutate(parent,MR)
_=fitness(child); if _<=close then iterate
close=_; almost=child
say almost right(close,9) right(gen,10)
end /*children*/
parent=almost
end /*gen*/
exit /*stick a fork in it, we're done.*/
/*───────────────────────────────────FITNESS subroutine─────────────────*/
fitness: parse arg x; hit=0; do k=1 for Ltar
hit=hit+(substr(x,k,1)==substr(target,k,1))
end /*k*/
return hit
/*───────────────────────────────────MUTATE subroutine──────────────────*/
mutate: parse arg x,rate,? /*set ? to a null, x=string. */
do j=1 for Ltar; r=random(1,100000)
if .00001*r<=rate then ?=? || substr(abc,r//Labc+1,1)
else ?=? || substr(x,j,1)
end /*j*/
return ?

36
Task/Evolutionary-algorithm/REXX/evolutionary-algorithm-2.rexx
View file

@ -1,35 +1,45 @@
/*REXX program demonstrates an evolutionary algorithm (using mutation).*/
parse arg children MR seed . /*get options (maybe) from C.L. */
if children=='' then children = 10 /*# of children produced each gen*/
if MR =='' then MR = '4%' /*the char Mutation Rate each gen*/
if right(MR,1)=='%' then MR=strip(MR,,'%')/100 /*expressed as %? Adjust*/
if seed\=='' then call random ,,seed /*allow the runs to be repeatable*/
if MR =='' then MR = "4%" /*the char Mutation Rate each gen*/
if right(MR,1)=='%' then MR=strip(MR,,"%")/100 /*expressed as %? Adjust*/
if seed\=='' then call random ,,seed /*allow the runs to be repeatable*/
abc = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ ' ; Labc=length(abc)
do i=0 for Labc /*define array (faster compare), */
A.i=substr(abc, i+1, 1) /* it's better than picking out a*/
end /*i*/ /* byte from a character string. */
target= 'METHINKS IT IS LIKE A WEASEL' ; Ltar=length(target)
parent= mutate( left('',Ltar), 1) /*gen rand str,same length as tar*/
say center('target string',Ltar,'─') "children" 'mutationRate'
say target center(children,8) center((MR*100/1)'%',12) ; say
say center('new string',Ltar,'─') "closeness" 'generation'
do i=1 for Ltar /*define array (faster compare), */
T.i=substr(target, i, 1) /*it's better than a byte-by-byte*/
end /*i*/ /*compare using character strings*/
parent= mutate( left('', Ltar), 1) /*gen rand str,same length as tar*/
say center('target string', Ltar, '─') "children" 'mutationRate'
say target center(children, 8) center((MR*100/1)'%', 12) ; say
say center('new string', Ltar, '─') "closeness" 'generation'
do gen=0 until parent==target; close=fitness(parent)
almost=parent
do children; child=mutate(parent,MR)
_=fitness(child); if _<=close then iterate
do children; child=mutate(parent, MR)
_=fitness(child); if _<=close then iterate
close=_; almost=child
say almost right(close,9) right(gen,10)
say almost right(close, 9) right(gen, 10)
end /*children*/
parent=almost
end /*gen*/
exit /*stick a fork in it, we're done.*/
/*───────────────────────────────────FITNESS subroutine─────────────────*/
fitness: parse arg x; hit=0; do k=1 for Ltar
hit=hit+(substr(x,k,1)==substr(target,k,1))
hit=hit + (substr(x,k,1) == T.k)
end /*k*/
return hit
/*───────────────────────────────────MUTATE subroutine──────────────────*/
mutate: parse arg x,rate,? /*set ? to a null, x=string. */
do j=1 for Ltar; r=random(1,100000)
if .00001*r<=rate then ?=? || substr(abc,r//Labc+1,1)
do j=1 for Ltar; r=random(1, 100000)
if .00001*r<=rate then do; _=r//Labc; ?=? || A._; end
else ?=? || substr(x,j,1)
end /*j*/
return ?

37
Task/Evolutionary-algorithm/Racket/evolutionary-algorithm.rkt Normal file
View file

@ -0,0 +1,37 @@
#lang racket
(define alphabet " ABCDEFGHIJKLMNOPQRSTUVWXYZ")
(define (randch) (string-ref alphabet (random 27)))
(define (fitness s1 s2)
(for/sum ([c1 (in-string s1)] [c2 (in-string s2)])
(if (eq? c1 c2) 1 0)))
(define (mutate s P)
(define r (string-copy s))
(for ([i (in-range (string-length r))] #:when (<= (random) P))
(string-set! r i (randch)))
r)
(define (evolution target C P)
(let loop ([parent (mutate target 1.0)] [n 0])
;; (printf "~a: ~a\n" n parent)
(if (equal? parent target)
n
(let cloop ([children (for/list ([i (in-range C)]) (mutate parent P))]
[best #f] [fit -1])
(if (null? children)
(loop best (add1 n))
(let ([f (fitness target (car children))])
(if (> f fit)
(cloop (cdr children) (car children) f)
(cloop (cdr children) best fit))))))))
;; Some random experiment using all of this
(define (try-run C P)
(define ns
(for/list ([i 10])
(evolution "METHINKS IT IS LIKE A WEASEL" C P)))
(printf "~s Average generation: ~s\n" C (/ (apply + 0.0 ns) (length ns)))
(printf "~s Total strings: ~s\n" C (for/sum ([n ns]) (* n 50))))
(for ([C (in-range 10 501 10)]) (try-run C 0.001))