Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

unicorn

  • Loading branch information...
commit 86ccadb5df4b60e65161cec88d34507b3f2f8b81 1 parent 04e353a
@banacorn authored
Showing with 325 additions and 0 deletions.
  1. +51 −0 data.hs
  2. +229 −0 main.hs
  3. +45 −0 wtf.hs
View
51 data.hs
@@ -0,0 +1,51 @@
+sechs = [
+ [35,36,36,36,37,39,40,41,41,42,44,44,46,46,46,46,47,48,48,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [35,38,38,39,38,40,40,42,42,44,43,46,46,46,47,47,49,49,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [35,38,38,40,41,41,41,44,45,45,45,46,46,47,47,48,48,49,49,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [35,36,40,41,42,42,43,44,44,45,45,45,46,47,47,48,48,48,49,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [36,36,37,37,38,39,40,41,42,42,44,45,44,44,45,46,47,47,47,48,48,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [35,37,37,38,38,41,42,42,43,43,44,44,46,46,47,48,48,48,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [34,36,36,38,39,39,40,41,41,44,43,44,45,46,47,47,49,49,48,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [34,35,37,40,40,43,45,44,45,45,45,46,47,48,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [35,37,37,39,39,40,41,41,42,44,44,45,48,48,49,48,48,49,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [34,36,37,38,37,38,40,41,42,44,44,45,45,47,47,48,48,48,48,48,49,49,49,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50]
+ ]
+
+sieben = [
+ [34,37,39,39,39,40,42,42,43,43,43,45,46,46,46,47,47,48,48,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [36,36,37,37,39,39,41,41,42,42,44,43,44,45,46,46,47,47,47,48,48,48,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [34,34,36,38,39,39,42,42,42,43,43,44,45,45,46,47,49,49,49,49,49,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [35,35,37,38,38,41,41,42,42,43,45,45,46,47,47,47,48,49,48,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [35,36,36,37,38,41,40,41,42,43,44,45,45,45,48,48,48,48,48,48,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [35,37,38,39,39,40,41,41,43,43,43,46,45,46,47,47,48,48,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [35,37,37,38,41,41,42,43,42,43,45,45,45,47,48,48,49,49,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [36,38,38,38,39,40,42,43,43,44,44,46,46,46,47,47,48,48,49,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [38,37,40,38,39,40,42,43,45,45,45,45,45,46,47,47,48,49,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
+ [37,37,37,38,39,40,40,41,43,44,44,45,45,46,47,47,47,48,48,49,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50]
+ ]
+
+drei = [
+ [34,35,36,36,36,35,37,38,37,38,37,36,37,39,38,39,38,37,39,37,36,38,38,39,39,39,38,38,38,38,37,39,38,39,39,39,40,39,41,40,40,40,42,41,42,42,42,43,41,42,42,42,42,43,42,42,43,43,44,43,44,43,45,45,44,45,44,44,44,45,45,45,46,46,46,47,47,46,47,48,48,46,47,46,46,46,47,46,46,47,46,47,46,46,47,47,46,47,47,46],
+ [35,34,35,35,37,37,38,37,38,37,37,36,38,38,39,38,40,39,40,40,40,41,42,42,42,43,42,43,44,44,44,44,45,44,44,45,46,45,45,45,45,46,48,45,44,47,46,47,47,45,47,46,46,46,46,46,46,45,46,46,47,47,47,47,48,48,46,46,47,47,47,47,47,48,48,48,48,48,48,48,48,47,48,48,48,48,49,49,49,48,48,48,48,49,50,49,49,48,49,49],
+ [34,34,35,33,34,35,35,35,35,35,36,36,36,37,38,36,37,38,38,37,38,38,38,38,39,40,39,40,40,42,41,41,42,42,42,42,42,44,43,42,43,43,43,43,44,42,42,44,44,44,45,45,46,45,45,44,45,46,45,45,44,45,44,44,44,45,45,45,45,45,46,45,46,46,46,46,46,46,46,46,46,47,46,47,47,47,47,46,46,47,46,46,47,47,47,47,46,47,47,47],
+ [35,35,37,35,38,39,40,37,39,39,39,40,39,40,39,39,41,41,40,41,41,41,41,41,41,42,41,42,44,44,43,44,43,44,44,44,45,44,45,44,44,44,45,45,43,44,45,45,44,43,44,44,45,44,44,44,45,45,45,45,45,45,45,45,47,46,45,45,46,46,47,46,46,47,46,45,46,46,46,46,48,46,46,47,47,48,48,47,47,47,47,47,47,47,47,47,47,48,48,48],
+ [33,35,34,35,35,34,35,36,37,37,38,37,37,39,36,38,38,40,38,38,39,39,38,38,38,40,40,39,40,39,39,39,39,40,41,40,41,42,43,43,44,42,43,43,43,44,44,44,44,44,45,46,46,46,46,45,45,45,46,46,46,45,46,46,45,46,46,46,46,46,46,48,48,48,49,49,49,47,47,47,47,47,47,46,47,47,47,47,47,47,47,47,47,47,47,47,47,48,48,47],
+ [35,34,33,32,33,34,35,34,36,36,37,37,38,38,37,36,39,40,39,40,42,42,42,42,40,39,40,40,41,41,42,41,44,44,41,42,42,43,44,43,43,42,45,44,44,45,45,47,47,47,45,46,47,47,47,48,48,47,46,47,48,48,48,48,47,48,48,48,49,48,49,49,49,49,50,49,50,50,50,50,50,50,50,50,50,50,50,49,50,50,49,49,50,50,50,50,50,50,50,50],
+ [33,34,34,34,37,36,35,38,38,40,38,39,40,40,38,41,43,44,42,42,42,43,42,41,42,41,44,43,43,41,42,44,44,44,42,44,44,45,44,45,44,44,45,44,45,45,45,44,44,46,46,45,44,44,46,44,44,45,45,45,46,46,45,45,45,45,46,46,46,47,47,47,47,47,46,46,48,46,47,46,47,46,46,47,46,47,47,47,47,47,48,47,48,48,47,47,47,47,48,47],
+ [35,34,35,36,37,38,38,38,38,39,38,40,39,41,42,41,40,43,41,41,42,41,44,43,44,43,41,42,42,44,44,42,42,43,42,41,43,43,43,43,42,42,43,43,42,44,44,43,44,44,44,44,45,45,45,45,46,45,45,45,46,45,45,45,46,46,47,46,46,46,46,47,47,47,47,47,47,48,49,48,48,48,49,49,49,49,49,50,50,49,49,49,49,49,49,49,49,49,50,50],
+ [34,34,34,34,34,35,35,35,38,39,39,40,39,38,39,38,38,40,41,41,40,40,41,41,41,40,42,40,41,42,41,41,41,41,41,41,41,42,42,41,41,42,42,42,44,43,43,44,44,44,44,44,45,45,44,46,44,45,46,46,46,45,47,46,47,46,46,46,47,46,47,46,46,47,46,46,47,47,47,47,47,47,48,48,48,48,47,47,48,48,47,48,48,48,48,48,48,48,48,48],
+ [34,35,35,38,35,35,35,37,37,37,37,36,37,37,38,37,37,39,40,39,39,39,39,38,39,40,40,40,41,42,42,41,42,43,45,45,44,44,44,45,43,43,45,45,45,44,45,46,46,46,47,46,48,46,46,47,47,47,46,47,46,47,47,47,47,47,47,48,47,47,49,48,48,49,48,48,48,48,48,48,48,47,47,48,47,47,48,48,48,47,46,48,48,47,47,48,48,48,48,48]
+ ]
+
+fier = [
+ [33,36,33,35,34,33,34,36,33,36,35,34,34,33,32,33,33,32,33,32,34,34,34,32,33,37,33,34,32,34,33,34,35,34,33,35,32,33,34,32,34,34,33,35,35,35,34,35,32,32,31,33,33,33,31,32,33,34,36,37,33,32,32,34,33,33,32,32,29,31,31,30,32,32,30,29,30,31,31,29,31,31,30,29,28,29,30,30,30,29,30,30,29,29,28,30,29,30,32,30],
+ [36,34,36,38,35,35,36,35,35,38,37,34,35,36,35,34,34,37,37,35,37,36,37,38,35,35,34,34,34,34,35,35,34,35,35,37,34,35,36,38,38,39,40,35,36,38,35,38,36,36,37,36,35,35,35,36,36,37,35,35,35,35,35,36,34,34,37,36,36,36,36,36,36,35,34,35,36,36,36,37,34,36,39,38,37,35,35,36,36,37,37,39,40,40,40,39,35,36,36,37],
+ [31,35,32,34,34,33,33,35,35,33,33,32,33,35,35,36,36,35,36,35,37,34,33,34,33,33,33,35,33,33,34,34,35,34,34,33,34,35,36,34,36,36,35,34,35,35,36,37,35,35,35,35,36,36,35,35,36,37,35,33,33,34,34,35,34,34,35,34,33,33,34,34,34,33,34,31,31,33,33,32,33,32,34,33,31,32,35,33,33,35,33,33,33,32,32,34,33,33,33,33],
+ [34,34,34,35,36,35,34,36,33,35,36,36,33,32,32,35,32,35,31,32,34,34,35,33,33,33,32,32,31,34,32,31,32,32,31,32,32,33,32,33,33,32,33,34,33,35,33,33,33,32,32,34,33,33,34,34,32,32,34,32,33,33,36,34,33,33,33,31,34,33,34,34,32,35,33,31,31,32,31,30,30,32,31,32,31,32,31,32,33,32,30,30,32,30,32,32,30,31,29,30],
+ [33,34,34,35,33,32,32,32,33,34,34,34,35,33,35,34,35,35,34,35,34,34,33,33,33,35,36,38,34,36,36,35,36,35,37,34,35,35,37,35,35,34,34,33,34,36,34,33,33,32,32,32,34,33,33,34,33,34,33,33,34,35,33,33,32,33,34,36,34,33,33,33,33,34,33,34,33,33,32,32,32,33,33,35,33,34,34,34,33,33,34,33,32,34,34,33,33,33,33,34],
+ [35,35,34,35,35,32,34,33,32,34,34,34,33,35,33,32,32,34,32,33,33,33,34,33,34,34,34,36,35,34,35,36,34,34,36,34,34,34,35,35,37,33,34,33,34,35,36,35,35,35,34,36,35,35,36,36,35,34,34,35,33,34,34,34,33,34,34,35,33,34,35,37,36,36,37,38,38,36,34,35,34,34,35,37,35,34,33,34,35,34,35,35,35,34,35,36,36,35,35,38],
+ [33,35,33,37,34,36,36,35,36,36,38,35,36,35,35,35,37,36,35,38,34,37,37,36,34,34,35,36,34,36,35,36,35,36,39,39,38,38,38,37,38,35,35,34,36,36,37,35,36,36,35,36,33,34,34,35,34,33,32,34,34,33,32,34,34,32,32,33,33,33,34,33,33,32,32,30,32,32,31,32,32,31,32,32,31,32,33,32,32,32,32,33,33,31,34,35,34,32,36,32],
+ [34,35,34,35,33,35,35,32,33,33,32,34,33,33,31,32,33,31,31,31,31,30,31,31,34,32,34,34,34,33,32,31,32,33,34,32,33,33,34,33,33,33,33,32,34,35,32,32,31,33,33,32,33,32,34,33,35,36,34,34,34,35,34,33,33,33,32,34,34,35,34,34,34,36,33,33,32,31,33,35,35,32,35,33,33,33,32,34,34,35,34,32,32,30,30,31,30,30,31,31],
+ [34,33,36,33,33,34,34,34,34,34,33,34,33,32,32,32,34,34,34,34,32,34,34,32,34,34,34,34,34,33,34,33,33,34,33,33,34,32,32,32,33,35,34,34,33,33,34,33,32,33,33,33,34,34,32,32,36,36,36,34,35,34,33,32,36,35,34,34,34,34,35,35,34,32,35,34,33,32,32,33,34,33,32,35,34,33,32,32,32,31,31,34,32,32,30,31,31,31,31,32],
+ [35,33,35,37,38,34,36,35,35,32,33,33,33,34,35,32,35,33,36,36,35,34,37,35,35,34,35,34,35,36,37,33,34,35,36,33,34,38,39,36,36,37,35,36,35,35,35,35,34,35,34,33,34,32,32,32,32,33,33,36,33,34,34,34,35,34,33,34,35,33,34,34,35,32,34,33,34,34,35,34,33,33,35,34,34,34,34,34,35,34,33,34,34,34,34,34,34,34,33,34]
+ ]
View
229 main.hs
@@ -0,0 +1,229 @@
+
+import Control.Monad
+import Control.Monad.State
+import Data.List
+--import qualified Data.List as L
+import qualified System.Random.MWC as MWC
+import qualified Control.Monad.Primitive as Prim
+import qualified Data.Vector as V
+
+type Fitness = Int
+type Prob = Double
+type Gene = Bool
+type Gen = MWC.Gen (Prim.PrimState IO)
+type Seed = MWC.Seed
+data Chromosome = Chromosome [Bool] deriving (Eq)
+
+data Config = Config {
+ representationLength :: Int,
+ population :: Int,
+ seed :: MWC.Seed,
+ best :: [Fitness]
+} deriving (Show)
+
+restore :: Config -> IO Gen
+restore config = MWC.restore seed'
+ where seed' = seed config
+
+save :: Config -> Gen -> IO Config
+save config gen = do
+ seed' <- MWC.save gen
+ return $ Config {
+ representationLength = representationLength config,
+ population = population config,
+ seed = seed',
+ best = best config
+ }
+ where seed' = seed config
+
+addRecord :: Race -> IO Race
+addRecord (Race pop config) = return $ Race pop $ Config {
+ representationLength = representationLength config,
+ population = population config,
+ seed = seed config,
+ best = bestFittest pop : oldBestFittest
+ }
+ where oldBestFittest = best config
+ bestFittest [Individual _ f] = f
+ bestFittest ((Individual _ f):xs) = f `max` bestFittest xs
+
+data Individual = Individual Chromosome Fitness deriving (Eq)
+data Race = Race [Individual] Config
+data MatingPool = MatingPool [(Individual, Individual)] Config
+
+
+instance Show Chromosome where
+ show (Chromosome chromosome) = bitstring ++ ":" ++ (show $ length chromosome)
+ where bitstring = map toBit chromosome
+ toBit True = '1'
+ toBit False = '0'
+instance Show Individual where
+ show (Individual chromosome fitness) = " " ++ show fitness ++ " " ++ show chromosome ++ " "
+instance Show Race where
+ show (Race pop config) = intercalate "\n" (map show pop)
+instance Show MatingPool where
+ show (MatingPool pop config) = intercalate "\n" (map show pop)
+instance Ord Individual where
+ compare (Individual _ fitness0) (Individual _ fitness1) = compare fitness0 fitness1
+
+unicorn = Race [] Config {
+ representationLength = 50,
+ population = 200,
+ seed = MWC.toSeed (V.singleton 42),
+ best = []
+}
+
+ca = chromosomeToIndividual $ Chromosome [True, True, True, True, True, True]
+cb = chromosomeToIndividual $ Chromosome [False, False, False, False, False, True]
+
+print' :: Show a => a -> IO a
+print' a = putStrLn (show a) >> return a
+
+newline :: Show a => a -> IO a
+newline a = putStrLn "" >> return a
+
+iterateM :: Monad m => Int -> m a -> (a -> m a) -> m a
+iterateM 0 c f = c
+iterateM n c f = iterateM (n - 1) c f >>= f
+
+fuck f = do
+ u <- initialize unicorn >>= initializeGen
+ Race _ config <- iterateM 100 (return u) (\s -> f s >>= crossover >>= evaluate >>= addRecord)
+ print . reverse . best $ config
+ --print . map (flip (-) 1000) . reverse . best $ config
+ --print . intercalate ", " . map (\(i, a) -> "[" ++ show i ++ ", " ++ show a ++ "]") . zip [0 ..] . reverse . best $ config
+ return ()
+
+
+main = replicateM_ 10 (fuck rouletteWheel)
+
+chromosomeToIndividual :: Chromosome -> Individual
+chromosomeToIndividual chromosome = Individual chromosome $ evaluateC chromosome
+
+initializeGen :: Race -> IO Race
+initializeGen (Race pop config) = do
+ a <- MWC.withSystemRandom . MWC.asGenST $ \gen -> MWC.uniform gen
+ gen <- MWC.initialize (V.singleton a)
+ config' <- save config gen
+ return (Race pop config')
+
+--
+-- INITIALIZE
+--
+
+initializeI :: Gen -> Int -> IO Individual
+initializeI gen len = do
+ c <- MWC.uniformVector gen len :: IO (V.Vector Int)
+ return (chromosomeToIndividual $ Chromosome (map even $ V.toList c))
+
+initialize :: Race -> IO Race
+initialize (Race _ config) = do
+ gen <- restore config
+ pop <- replicateM population' (initializeI gen representationLength')
+ config' <- save config gen
+ return (Race pop config')
+ where population' = population config
+ representationLength' = representationLength config
+--
+-- EVALUATE
+--
+
+evaluateC :: Chromosome -> Fitness
+evaluateC (Chromosome chromosome) = fuck
+ where fuck = fitness
+ fitness = (sum $ map toBit chromosome)
+ toBit True = 1
+ toBit False = 0
+
+evaluateI :: Individual -> Individual
+evaluateI (Individual chromosome _) = Individual chromosome $ evaluateC chromosome
+
+evaluate :: Race -> IO Race
+evaluate (Race pop config) = return $ Race (map evaluateI pop) config
+
+averageFitness :: Race -> IO Race
+averageFitness (Race pop config) = do
+ print $ fromIntegral sum / fromIntegral (population config)
+ return (Race pop config)
+ where sum = gather pop
+ gather [] = 0
+ gather ((Individual _ f):xs) = f + gather xs
+
+--
+-- SELECTION
+--
+
+
+
+rouletteWheelI :: [Individual] -> Gen -> IO Individual
+rouletteWheelI pop gen = do
+ let total = totalFitness pop
+ number <- MWC.uniformR (0, total) gen
+ return (spinWheel number pop)
+ where
+ totalFitness [] = 0
+ totalFitness ((Individual _ fitness):xs) = fitness + totalFitness xs
+ spinWheel number [x] = x
+ spinWheel number (x:xs)
+ | number <= fitness = x
+ | otherwise = spinWheel (number - fitness) xs
+ where (Individual _ fitness) = x
+
+rouletteWheel :: Race -> IO MatingPool
+rouletteWheel (Race pop config) = do
+ gen <- restore config
+ male <- replicateM halfPopulationSize (rouletteWheelI pop gen)
+ female <- replicateM halfPopulationSize (rouletteWheelI pop gen)
+ config' <- save config gen
+ return (MatingPool (zip male female) config')
+ where halfPopulationSize = population config `div` 2
+
+
+tournamentI :: [Individual] -> Gen -> IO Individual
+tournamentI pop gen = do
+ na <- MWC.uniformR (0, size - 1) gen
+ nb <- MWC.uniformR (0, size - 1) gen
+ let a = pop !! na
+ let b = pop !! nb
+ return (max a b)
+ where size = length pop
+
+
+tournament :: Race -> IO MatingPool
+tournament (Race pop config) = do
+ gen <- restore config
+ male <- replicateM halfPopulationSize (tournamentI pop gen)
+ female <- replicateM halfPopulationSize (tournamentI pop gen)
+ config' <- save config gen
+ return (MatingPool (zip male female) config')
+ where halfPopulationSize = population config `div` 2
+
+
+
+
+
+
+--
+-- XOVER
+--
+
+crossoverI :: Gen -> (Individual, Individual) -> IO (Individual, Individual)
+crossoverI gen (Individual (Chromosome chromosome0) _, Individual (Chromosome chromosome1) _) = do
+ point <- MWC.uniformR (0, chromosomeLength) gen
+ let (head0, tail0) = splitAt point chromosome0
+ let (head1, tail1) = splitAt point chromosome1
+ let chromosome0' = Chromosome $ head0 ++ tail1
+ let chromosome1' = Chromosome $ head1 ++ tail0
+ return (Individual chromosome0' 0, Individual chromosome1' 0)
+ where chromosomeLength = length chromosome0
+
+crossover :: MatingPool -> IO Race
+crossover (MatingPool mates config) = do
+ gen <- restore config
+ children <- mapM (crossoverI gen) mates
+ let newPopulation = concat $ map pair2list children
+ config' <- save config gen
+ return (Race newPopulation config')
+ where halfPopulationSize = population config `div` 2
+ pair2list (a, b) = [a, b]
+
View
45 wtf.hs
@@ -0,0 +1,45 @@
+
+
+--fuck gen = MWC.initialize (V.singleton 100) >>= MWC.uniformR (0, 100) :: ST t Int
+--
+--newtype State s a = State { run :: s -> (a, s) }
+--data State s a = State (s -> (a, s))
+
+--run (State f) = f
+
+-- >>= :: m a -> (a -> m b) -> m b
+-- >>= :: State s a -> (a -> State s b) -> State s b
+-- >>= :: State (s -> (a, s)) -> (a -> State (s -> (b, s))) -> State (s -> (b, s))
+
+--instance Monad (State s) where
+-- return a = State $ \s -> (a, s)
+-- State run >>= f = State $ \s -> let (a, s') = run s
+-- State f' = f a
+-- in f' s
+--data Stack a = Stack [a] deriving (Show)
+
+--instance Monad Stack where
+-- return a = Stack [a]
+-- Stack [] >>= f = Stack []
+-- Stack (n:ns) >>= f = Stack (n' ++ rest)
+-- where Stack n' = f n
+-- Stack rest = Stack ns >>= f
+
+
+--push :: Int -> State Stack ()
+--push a = do
+-- put a
+-- return ()
+
+
+--push :: Int -> State Stack ()
+--push a = StateT $ \as -> ((), a:as)
+
+--pop :: ST Stack Int
+--pop = StateT $ \(x:xs) -> (x, xs)
+
+--f = pop >> push 4
+
+--pop (Stack []) = ((), Stack [])
+--pop (Stack (x:xs)) = (x, Stack xs)
+--push n (Stack ns) = ((), Stack (n:ns))
Please sign in to comment.
Something went wrong with that request. Please try again.