Data update

Task/Evolutionary-algorithm/Ada/evolutionary-algorithm.adb

@@ -0,0 +1,124 @@
+with Ada.Text_IO;
+with Ada.Numerics.Discrete_Random;
+with Ada.Numerics.Float_Random;
+with Ada.Strings.Fixed;
+with Ada.Strings.Maps;
+
+procedure Evolution is
+
+   -- only upper case characters allowed, and space, which uses '@' in
+   -- internal representation (allowing subtype of Character).
+   subtype DNA_Char is Character range '@' .. 'Z';
+
+   -- DNA string is as long as target string.
+   subtype DNA_String is String (1 .. 28);
+
+   -- target string translated to DNA_Char string
+   Target : constant DNA_String := "METHINKS@IT@IS@LIKE@A@WEASEL";
+
+   -- calculate the 'closeness' to the target DNA.
+   -- it returns a number >= 0 that describes how many chars are correct.
+   -- can be improved much to make evolution better, but keep simple for
+   -- this example.
+   function Fitness (DNA : DNA_String) return Natural is
+      Result : Natural := 0;
+   begin
+      for Position in DNA'Range loop
+         if DNA (Position) = Target (Position) then
+            Result := Result + 1;
+         end if;
+      end loop;
+      return Result;
+   end Fitness;
+
+   -- output the DNA using the mapping
+   procedure Output_DNA (DNA : DNA_String; Prefix : String := "") is
+      use Ada.Strings.Maps;
+      Output_Map : Character_Mapping;
+   begin
+      Output_Map := To_Mapping
+        (From => To_Sequence (To_Set (('@'))),
+         To   => To_Sequence (To_Set ((' '))));
+      Ada.Text_IO.Put (Prefix);
+      Ada.Text_IO.Put (Ada.Strings.Fixed.Translate (DNA, Output_Map));
+      Ada.Text_IO.Put_Line (", fitness: " & Integer'Image (Fitness (DNA)));
+   end Output_DNA;
+
+   -- DNA_Char is a discrete type, use Ada RNG
+   package Random_Char is new Ada.Numerics.Discrete_Random (DNA_Char);
+   DNA_Generator : Random_Char.Generator;
+
+   -- need generator for floating type, too
+   Float_Generator : Ada.Numerics.Float_Random.Generator;
+
+   -- returns a mutated copy of the parent, applying the given mutation rate
+   function Mutate (Parent        : DNA_String;
+                    Mutation_Rate : Float)
+                    return          DNA_String
+   is
+      Result : DNA_String := Parent;
+   begin
+      for Position in Result'Range loop
+         if Ada.Numerics.Float_Random.Random (Float_Generator) <= Mutation_Rate
+         then
+            Result (Position) := Random_Char.Random (DNA_Generator);
+         end if;
+      end loop;
+      return Result;
+   end Mutate;
+
+   -- genetic algorithm to evolve the string
+   -- could be made a function returning the final string
+   procedure Evolve (Child_Count   : Positive := 100;
+                     Mutation_Rate : Float    := 0.2)
+   is
+      type Child_Array is array (1 .. Child_Count) of DNA_String;
+
+      -- determine the fittest of the candidates
+      function Fittest (Candidates : Child_Array) return DNA_String is
+         The_Fittest : DNA_String := Candidates (1);
+      begin
+         for Candidate in Candidates'Range loop
+            if Fitness (Candidates (Candidate)) > Fitness (The_Fittest)
+            then
+               The_Fittest := Candidates (Candidate);
+            end if;
+         end loop;
+         return The_Fittest;
+      end Fittest;
+
+      Parent, Next_Parent : DNA_String;
+      Children            : Child_Array;
+      Loop_Counter        : Positive := 1;
+   begin
+      -- initialize Parent
+      for Position in Parent'Range loop
+         Parent (Position) := Random_Char.Random (DNA_Generator);
+      end loop;
+      Output_DNA (Parent, "First: ");
+      while Parent /= Target loop
+         -- mutation loop
+         for Child in Children'Range loop
+            Children (Child) := Mutate (Parent, Mutation_Rate);
+         end loop;
+         Next_Parent := Fittest (Children);
+         -- don't allow weaker children as the parent
+         if Fitness (Next_Parent) > Fitness (Parent) then
+            Parent := Next_Parent;
+         end if;
+         -- output every 20th generation
+         if Loop_Counter mod 20 = 0 then
+            Output_DNA (Parent, Integer'Image (Loop_Counter) & ": ");
+         end if;
+         Loop_Counter := Loop_Counter + 1;
+      end loop;
+      Output_DNA (Parent, "Final (" & Integer'Image (Loop_Counter) & "): ");
+   end Evolve;
+
+begin
+   -- initialize the random number generators
+   Random_Char.Reset (DNA_Generator);
+   Ada.Numerics.Float_Random.Reset (Float_Generator);
+   -- evolve!
+   Evolve;
+end Evolution;

Task/Evolutionary-algorithm/COBOL/evolutionary-algorithm.cob

@@ -0,0 +1,88 @@
+identification division.
+program-id. evolutionary-program.
+data division.
+working-storage section.
+01  evolving-strings.
+    05 target                pic a(28)
+        value 'METHINKS IT IS LIKE A WEASEL'.
+    05 parent                pic a(28).
+    05 offspring-table.
+        10 offspring         pic a(28)
+            occurs 50 times.
+01  fitness-calculations.
+    05 fitness               pic 99.
+    05 highest-fitness       pic 99.
+    05 fittest               pic 99.
+01  parameters.
+    05 character-set         pic a(27)
+        value 'ABCDEFGHIJKLMNOPQRSTUVWXYZ '.
+    05 size-of-generation    pic 99
+        value 50.
+    05 mutation-rate         pic 99
+        value 5.
+01  counters-and-working-variables.
+    05 character-position    pic 99.
+    05 randomization.
+        10 random-seed       pic 9(8).
+        10 random-number     pic 99.
+        10 random-letter     pic 99.
+    05 generation            pic 999.
+    05 child                 pic 99.
+    05 temporary-string      pic a(28).
+procedure division.
+control-paragraph.
+    accept random-seed from time.
+    move function random(random-seed) to random-number.
+    perform random-letter-paragraph,
+    varying character-position from 1 by 1
+    until character-position is greater than 28.
+    move temporary-string to parent.
+    move zero to generation.
+    perform output-paragraph.
+    perform evolution-paragraph,
+    varying generation from 1 by 1
+    until parent is equal to target.
+    stop run.
+evolution-paragraph.
+    perform mutation-paragraph varying child from 1 by 1
+    until child is greater than size-of-generation.
+    move zero to highest-fitness.
+    move 1 to fittest.
+    perform check-fitness-paragraph varying child from 1 by 1
+    until child is greater than size-of-generation.
+    move offspring(fittest) to parent.
+    perform output-paragraph.
+output-paragraph.
+    display generation ': ' parent.
+random-letter-paragraph.
+    move function random to random-number.
+    divide random-number by 3.80769 giving random-letter.
+    add 1 to random-letter.
+    move character-set(random-letter:1)
+    to temporary-string(character-position:1).
+mutation-paragraph.
+    move parent to temporary-string.
+    perform character-mutation-paragraph,
+    varying character-position from 1 by 1
+    until character-position is greater than 28.
+    move temporary-string to offspring(child).
+character-mutation-paragraph.
+    move function random to random-number.
+    if random-number is less than mutation-rate
+    then perform random-letter-paragraph.
+check-fitness-paragraph.
+    move offspring(child) to temporary-string.
+    perform fitness-paragraph.
+fitness-paragraph.
+    move zero to fitness.
+    perform character-fitness-paragraph,
+    varying character-position from 1 by 1
+    until character-position is greater than 28.
+    if fitness is greater than highest-fitness
+    then perform fittest-paragraph.
+character-fitness-paragraph.
+    if temporary-string(character-position:1) is equal to
+    target(character-position:1) then add 1 to fitness.
+fittest-paragraph.
+    move fitness to highest-fitness.
+    move child to fittest.

Task/Evolutionary-algorithm/EasyLang/evolutionary-algorithm.easy

@@ -11,7 +11,7 @@ func fitness trial$ .
 func$ mutate parent$ .
    for c$ in strchars parent$
       if randomf < P
-         res$ &= abc$[random len abc$[]]
+         res$ &= abc$[random 1 len abc$[]]
       else
          res$ &= c$
       .
@@ -19,7 +19,7 @@ func$ mutate parent$ .
    return res$
 .
 for i to len target$
-   parent$ &= abc$[random len abc$[]]
+   parent$ &= abc$[random 1 len abc$[]]
 .
 while fitness parent$ > 0
    copies$[] = [ ]

Task/Evolutionary-algorithm/Euphoria/evolutionary-algorithm.eu

@@ -0,0 +1,51 @@
+constant table = "ABCDEFGHIJKLMNOPQRSTUVWXYZ "
+function random_generation(integer len)
+    sequence s
+    s = rand(repeat(length(table),len))
+    for i = 1 to len do
+        s[i] = table[s[i]]
+    end for
+    return s
+end function
+
+function mutate(sequence s, integer n)
+    for i = 1 to length(s) do
+        if rand(n) = 1 then
+            s[i] = table[rand(length(table))]
+        end if
+    end for
+    return s
+end function
+
+function fitness(sequence probe, sequence target)
+    atom sum
+    sum = 0
+    for i = 1 to length(target) do
+        sum += power(find(target[i], table) - find(probe[i], table), 2)
+    end for
+    return sqrt(sum/length(target))
+end function
+
+constant target = "METHINKS IT IS LIKE A WEASEL", C = 30, MUTATE = 15
+sequence parent, specimen
+integer iter, best
+atom fit, best_fit
+parent = random_generation(length(target))
+iter = 0
+while not equal(parent,target) do
+    best_fit = fitness(parent, target)
+    printf(1,"Iteration: %3d, \"%s\", deviation %g\n", {iter, parent, best_fit})
+    specimen = repeat(parent,C+1)
+    best = C+1
+    for i = 1 to C do
+        specimen[i] = mutate(specimen[i], MUTATE)
+        fit = fitness(specimen[i], target)
+        if fit < best_fit then
+            best_fit = fit
+            best = i
+        end if
+    end for
+    parent = specimen[best]
+    iter += 1
+end while
+printf(1,"Finally, \"%s\"\n",{parent})

Task/Evolutionary-algorithm/Rebol/evolutionary-algorithm.rebol

@@ -0,0 +1,65 @@
+Rebol [
+    title: "Rosetta code: Evolutionary algorithm"
+    file:  %Evolutionary_algorithm.r3
+    url:   https://rosettacode.org/wiki/Evolutionary_algorithm
+    note:  "Based on Red language solution"
+]
+
+evolve: function/with [
+    target [string!]  "target phrase to evolve toward"
+    childs [integer!] "number of offspring per generation"
+    rate   [number!]  "per-character mutation probability (0.0..1.0)"
+][
+    ;; create initial random parent of same length as target
+    parent: clear ""
+    repeat i length? target [
+        append parent random/only alphabet
+    ]
+    ;; main loop: generate children, select fittest, repeat until exact match
+    mutations: 0
+    while [parent != target] [
+        clear children
+        repeat i childs [
+            append children mutate parent rate  ;; produce a mutated child from parent
+        ]
+        sort/compare children :sort-fitness     ;; sort children by fitness (best first)
+        parent: first children                  ;; select best child as new parent
+        ++ mutations
+        prin #"^M"                              ;; carriage return to overwrite line
+        prin parent
+    ]
+    prin #"^M"                                  ;; move to line start
+    print parent                                ;; final perfect match
+    mutations
+][
+    alphabet: "ABCDEFGHIJKLMNOPQRSTUVWXYZ "     ;; allowed gene pool (uppercase letters + space)
+    children: copy []                           ;; reusable buffer for a generation's children
+
+    ;; compute closeness of 'string' to 'target' as Hamming distance (lower is better)
+    fitness: function [string] [
+        sum: 0
+        repeat i length? string [
+            if string/:i <> target/:i [ ++ sum ]  ;; count mismatched positions
+        ]
+        sum
+    ]
+
+    ;; return a mutated copy of 'string'; each position mutates with probability 'rate'
+    mutate: function [string rate] [
+        result: copy string
+        repeat i length? result [
+            if rate > random 1.0 [
+                result/:i: random/only alphabet   ;; replace char with random from alphabet
+            ]
+        ]
+        result
+    ]
+
+    ;; comparison function for sorting: a < b if fitness(a) < fitness(b)
+    sort-fitness: function [a b] [lesser? fitness a fitness b]
+]
+
+;; run the evolution demo
+random/seed 1
+m: evolve "METHINKS IT IS LIKE A WEASEL" 20 0.05
+print ["Target found using" as-yellow m "mutations."]

Task/Evolutionary-algorithm/VBScript/evolutionary-algorithm.vbs

@@ -0,0 +1,60 @@
+Option explicit
+
+Function rand(l,u) rand= Int((u-l+1)*Rnd+l): End Function
+
+Function fitness(i)
+  Dim d,j
+  d=0
+  For j=1 To lmod
+     If Mid(model,j,1)=Mid(cpy(i),j,1) Then d=d+1
+  Next
+fitness=d
+End Function
+
+Sub mutate(i)
+Dim j
+ cpy(i)=""
+ For j=1 To lmod
+ If Rnd<mut Then
+  cpy(i)=cpy(i)& Chr(rand(lb,ub))
+ Else
+  cpy(i)=cpy(i)& Mid(cpy(0),j,1)
+ End If
+ Next
+End sub
+
+Sub print(s):
+   On Error Resume Next
+    WScript.stdout.WriteLine (s)
+   If  err= &h80070006& Then WScript.Echo " Please run this script with CScript": WScript.quit
+End Sub
+
+Dim model,lmod,ub,lb,c,cpy,fit,best,i,d,mut,cnt
+model="METHINKS IT IS LIKE A WEASEL"
+model=Replace(model," ","@")
+lmod=Len(model)
+Randomize Timer
+ub=Asc("Z")
+lb=Asc("@")
+c=10
+mut=.05
+best=0
+ReDim cpy(c)
+
+
+For i=0 To lmod-1
+ cpy(best)=cpy(best)& chr(rand(lb,ub))
+Next
+best=0
+cnt=0
+do
+  cpy(0)=cpy(best)
+  fit=0
+  For i=1 To c
+   mutate(i)
+   d=fitness(i)
+   If d>fit Then fit=d:best=i
+  Next
+  cnt=cnt+1
+  If (fit=lmod) Or ((cnt mod 10)=0)  Then print cnt &" " & fit & " "& Replace (cpy(best),"@"," ")
+Loop While fit <>lmod