src/GA.hs

@@ -31,7 +31,6 @@ import Data.Random
 import Pipes
 import Pretty
 import Protolude
-import Protolude.Error
 import System.Random.MWC (create, createSystemRandom)
 import Test.QuickCheck hiding (sample, shuffle)
 import Test.QuickCheck.Instances ()
@@ -56,7 +55,7 @@ class (Pretty e, Individual i) => Environment i e | e -> i where
   --  Generates a random population of the given size.
   population :: e -> N -> RVar (Population i)
   population env n
-    | n <= 0 = error "nonPositive in population"
+    | n <= 0 = undefined
     | otherwise = NE.fromList <$> replicateM n (new env)
 
   mutate :: e -> i -> RVar i
@@ -267,7 +266,7 @@ tournament1 ::
   RVar i
 tournament1 eval nTrnmnt pop
   -- TODO Use Positive for this constraint
-  | nTrnmnt <= 0 = error "nonPositive in tournament1"
+  | nTrnmnt <= 0 = undefined
   | otherwise = do
       paricipants <- withoutReplacement nTrnmnt pop
       return $ NE.head $ fst $ bests eval 1 paricipants
@@ -280,7 +279,7 @@ withoutReplacement ::
   N ->
   Population i ->
   RVar (NonEmpty i)
-withoutReplacement 0 _ = error "0 in withoutReplacement"
+withoutReplacement 0 _ = undefined
 withoutReplacement n pop
   | n >= length pop = return pop
   | otherwise = fmap (NE.fromList) (shuffleNofM n (length pop) (NE.toList pop))

src/IrisData.hs

@@ -17,6 +17,40 @@ instance ToRecord IrisClass
 
 irisTrainingData :: [((Float, Float, Float, Float), IrisClass)]
 irisTrainingData =
+  [ ((5.0, 3.5, 1.6, 0.6), Setosa),
+    ((4.6, 3.1, 1.5, 0.2), Setosa),
+    ((4.8, 3.4, 1.6, 0.2), Setosa),
+    ((4.8, 3.0, 1.4, 0.3), Setosa),
+    ((6.4, 2.9, 4.3, 1.3), Versicolor),
+    ((5.5, 2.6, 4.4, 1.2), Versicolor),
+    ((5.2, 2.7, 3.9, 1.4), Versicolor),
+    ((6.0, 2.9, 4.5, 1.5), Versicolor),
+    ((5.3, 3.7, 1.5, 0.2), Setosa),
+    ((6.4, 3.2, 5.3, 2.3), Virginica),
+    ((6.4, 3.1, 5.5, 1.8), Virginica),
+    ((5.1, 3.8, 1.6, 0.2), Setosa),
+    ((5.1, 3.7, 1.5, 0.4), Setosa),
+    ((4.6, 3.4, 1.4, 0.3), Setosa),
+    ((5.6, 3.0, 4.1, 1.3), Versicolor),
+    ((6.1, 3.0, 4.6, 1.4), Versicolor),
+    ((5.2, 3.5, 1.5, 0.2), Setosa),
+    ((7.4, 2.8, 6.1, 1.9), Virginica),
+    ((6.5, 2.8, 4.6, 1.5), Versicolor),
+    ((6.3, 3.3, 6.0, 2.5), Virginica),
+    ((4.8, 3.1, 1.6, 0.2), Setosa),
+    ((7.7, 3.0, 6.1, 2.3), Virginica),
+    ((6.0, 2.2, 5.0, 1.5), Virginica),
+    ((5.5, 2.5, 4.0, 1.3), Versicolor),
+    ((6.5, 3.0, 5.5, 1.8), Virginica),
+    ((4.4, 2.9, 1.4, 0.2), Setosa),
+    ((6.4, 3.2, 4.5, 1.5), Versicolor),
+    ((5.0, 3.4, 1.6, 0.4), Setosa),
+    ((6.1, 2.6, 5.6, 1.4), Virginica),
+    ((6.6, 2.9, 4.6, 1.3), Versicolor)
+  ]
+
+irisTestData :: [((Float, Float, Float, Float), IrisClass)]
+irisTestData =
     [((6.7, 3.1, 4.4, 1.4), Versicolor),
     ((5.4, 3.7, 1.5, 0.2), Setosa),
     ((5.4, 3.0, 4.5, 1.5), Versicolor),
@@ -136,39 +170,4 @@ irisTrainingData =
     ((5.7, 2.5, 5.0, 2.0), Virginica),
     ((6.8, 2.8, 4.8, 1.4), Versicolor),
     ((6.3, 2.9, 5.6, 1.8), Virginica),
-    ((6.0, 2.2, 4.0, 1.0), Versicolor)
+    ((6.0, 2.2, 4.0, 1.0), Versicolor)]
-  ]
-
-irisTestData :: [((Float, Float, Float, Float), IrisClass)]
-irisTestData =
-  [ ((5.0, 3.5, 1.6, 0.6), Setosa),
-    ((4.6, 3.1, 1.5, 0.2), Setosa),
-    ((4.8, 3.4, 1.6, 0.2), Setosa),
-    ((4.8, 3.0, 1.4, 0.3), Setosa),
-    ((6.4, 2.9, 4.3, 1.3), Versicolor),
-    ((5.5, 2.6, 4.4, 1.2), Versicolor),
-    ((5.2, 2.7, 3.9, 1.4), Versicolor),
-    ((6.0, 2.9, 4.5, 1.5), Versicolor),
-    ((5.3, 3.7, 1.5, 0.2), Setosa),
-    ((6.4, 3.2, 5.3, 2.3), Virginica),
-    ((6.4, 3.1, 5.5, 1.8), Virginica),
-    ((5.1, 3.8, 1.6, 0.2), Setosa),
-    ((5.1, 3.7, 1.5, 0.4), Setosa),
-    ((4.6, 3.4, 1.4, 0.3), Setosa),
-    ((5.6, 3.0, 4.1, 1.3), Versicolor),
-    ((6.1, 3.0, 4.6, 1.4), Versicolor),
-    ((5.2, 3.5, 1.5, 0.2), Setosa),
-    ((7.4, 2.8, 6.1, 1.9), Virginica),
-    ((6.5, 2.8, 4.6, 1.5), Versicolor),
-    ((6.3, 3.3, 6.0, 2.5), Virginica),
-    ((4.8, 3.1, 1.6, 0.2), Setosa),
-    ((7.7, 3.0, 6.1, 2.3), Virginica),
-    ((6.0, 2.2, 5.0, 1.5), Virginica),
-    ((5.5, 2.5, 4.0, 1.3), Versicolor),
-    ((6.5, 3.0, 5.5, 1.8), Virginica),
-    ((4.4, 2.9, 1.4, 0.2), Setosa),
-    ((6.4, 3.2, 4.5, 1.5), Versicolor),
-    ((5.0, 3.4, 1.6, 0.4), Setosa),
-    ((6.1, 2.6, 5.6, 1.4), Virginica),
-    ((6.6, 2.9, 4.6, 1.3), Versicolor)
-  ]

src/IrisData.hs.template

@@ -1,177 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module IrisData where
-
-import Data.Csv
-import Protolude
-
-data IrisClass = Setosa | Virginica | Versicolor deriving (Eq, Generic, Show, Enum, Bounded)
-
-instance FromRecord IrisClass
-
-instance ToRecord IrisClass
-
-irisData :: [((Float, Float, Float, Float), IrisClass)]
-irisData =
-  [
-    ((5.0, 3.5, 1.6, 0.6), Setosa),
-    ((4.6, 3.1, 1.5, 0.2), Setosa),
-    ((4.8, 3.4, 1.6, 0.2), Setosa),
-    ((4.8, 3.0, 1.4, 0.3), Setosa),
-    ((6.4, 2.9, 4.3, 1.3), Versicolor),
-    ((5.5, 2.6, 4.4, 1.2), Versicolor),
-    ((5.2, 2.7, 3.9, 1.4), Versicolor),
-    ((6.0, 2.9, 4.5, 1.5), Versicolor),
-    ((5.3, 3.7, 1.5, 0.2), Setosa),
-    ((6.4, 3.2, 5.3, 2.3), Virginica),
-    ((6.4, 3.1, 5.5, 1.8), Virginica),
-    ((5.1, 3.8, 1.6, 0.2), Setosa),
-    ((5.1, 3.7, 1.5, 0.4), Setosa),
-    ((4.6, 3.4, 1.4, 0.3), Setosa),
-    ((5.6, 3.0, 4.1, 1.3), Versicolor),
-    ((6.1, 3.0, 4.6, 1.4), Versicolor),
-    ((5.2, 3.5, 1.5, 0.2), Setosa),
-    ((7.4, 2.8, 6.1, 1.9), Virginica),
-    ((6.5, 2.8, 4.6, 1.5), Versicolor),
-    ((6.3, 3.3, 6.0, 2.5), Virginica),
-    ((4.8, 3.1, 1.6, 0.2), Setosa),
-    ((7.7, 3.0, 6.1, 2.3), Virginica),
-    ((6.0, 2.2, 5.0, 1.5), Virginica),
-    ((5.5, 2.5, 4.0, 1.3), Versicolor),
-    ((6.5, 3.0, 5.5, 1.8), Virginica),
-    ((4.4, 2.9, 1.4, 0.2), Setosa),
-    ((6.4, 3.2, 4.5, 1.5), Versicolor),
-    ((5.0, 3.4, 1.6, 0.4), Setosa),
-    ((6.1, 2.6, 5.6, 1.4), Virginica),
-    ((6.6, 2.9, 4.6, 1.3), Versicolor),
-    ((6.7, 3.1, 4.4, 1.4), Versicolor),
-    ((5.4, 3.7, 1.5, 0.2), Setosa),
-    ((5.4, 3.0, 4.5, 1.5), Versicolor),
-    ((5.1, 3.8, 1.5, 0.3), Setosa),
-    ((5.0, 2.3, 3.3, 1.0), Versicolor),
-    ((6.0, 2.7, 5.1, 1.6), Versicolor),
-    ((4.6, 3.2, 1.4, 0.2), Setosa),
-    ((5.6, 2.7, 4.2, 1.3), Versicolor),
-    ((6.7, 3.3, 5.7, 2.1), Virginica),
-    ((6.9, 3.1, 5.1, 2.3), Virginica),
-    ((7.7, 3.8, 6.7, 2.2), Virginica),
-    ((6.1, 2.8, 4.7, 1.2), Versicolor),
-    ((5.8, 2.7, 3.9, 1.2), Versicolor),
-    ((6.7, 3.3, 5.7, 2.5), Virginica),
-    ((5.0, 3.4, 1.5, 0.2), Setosa),
-    ((4.7, 3.2, 1.6, 0.2), Setosa),
-    ((6.8, 3.0, 5.5, 2.1), Virginica),
-    ((6.2, 2.2, 4.5, 1.5), Versicolor),
-    ((5.7, 3.8, 1.7, 0.3), Setosa),
-    ((5.8, 4.0, 1.2, 0.2), Setosa),
-    ((7.2, 3.2, 6.0, 1.8), Virginica),
-    ((5.8, 2.7, 4.1, 1.0), Versicolor),
-    ((6.5, 3.0, 5.8, 2.2), Virginica),
-    ((6.9, 3.2, 5.7, 2.3), Virginica),
-    ((5.8, 2.7, 5.1, 1.9), Virginica),
-    ((5.2, 4.1, 1.5, 0.1), Setosa),
-    ((4.6, 3.6, 1.0, 0.2), Setosa),
-    ((4.7, 3.2, 1.3, 0.2), Setosa),
-    ((6.9, 3.1, 5.4, 2.1), Virginica),
-    ((6.1, 2.9, 4.7, 1.4), Versicolor),
-    ((6.0, 3.4, 4.5, 1.6), Versicolor),
-    ((5.6, 3.0, 4.5, 1.5), Versicolor),
-    ((5.2, 3.4, 1.4, 0.2), Setosa),
-    ((6.3, 3.3, 4.7, 1.6), Versicolor),
-    ((7.2, 3.6, 6.1, 2.5), Virginica),
-    ((6.5, 3.2, 5.1, 2.0), Virginica),
-    ((6.3, 2.5, 4.9, 1.5), Versicolor),
-    ((5.1, 3.8, 1.9, 0.4), Setosa),
-    ((7.0, 3.2, 4.7, 1.4), Versicolor),
-    ((4.9, 3.1, 1.5, 0.1), Setosa),
-    ((4.9, 2.4, 3.3, 1.0), Versicolor),
-    ((6.1, 3.0, 4.9, 1.8), Virginica),
-    ((4.9, 3.1, 1.5, 0.1), Setosa),
-    ((6.2, 2.9, 4.3, 1.3), Versicolor),
-    ((5.7, 3.0, 4.2, 1.2), Versicolor),
-    ((7.2, 3.0, 5.8, 1.6), Virginica),
-    ((5.0, 2.0, 3.5, 1.0), Versicolor),
-    ((4.3, 3.0, 1.1, 0.1), Setosa),
-    ((6.7, 3.1, 4.7, 1.5), Versicolor),
-    ((5.5, 2.4, 3.8, 1.1), Versicolor),
-    ((5.7, 2.8, 4.5, 1.3), Versicolor),
-    ((7.7, 2.8, 6.7, 2.0), Virginica),
-    ((7.6, 3.0, 6.6, 2.1), Virginica),
-    ((4.9, 2.5, 4.5, 1.7), Virginica),
-    ((5.1, 2.5, 3.0, 1.1), Versicolor),
-    ((6.4, 2.8, 5.6, 2.1), Virginica),
-    ((6.4, 2.8, 5.6, 2.2), Virginica),
-    ((5.9, 3.0, 5.1, 1.8), Virginica),
-    ((4.4, 3.2, 1.3, 0.2), Setosa),
-    ((6.3, 2.3, 4.4, 1.3), Versicolor),
-    ((5.4, 3.4, 1.7, 0.2), Setosa),
-    ((4.9, 3.0, 1.4, 0.2), Setosa),
-    ((6.7, 3.0, 5.2, 2.3), Virginica),
-    ((5.0, 3.5, 1.3, 0.3), Setosa),
-    ((5.1, 3.3, 1.7, 0.5), Setosa),
-    ((7.7, 2.6, 6.9, 2.3), Virginica),
-    ((5.6, 2.9, 3.6, 1.3), Versicolor),
-    ((7.3, 2.9, 6.3, 1.8), Virginica),
-    ((6.7, 3.1, 5.6, 2.4), Virginica),
-    ((6.3, 2.8, 5.1, 1.5), Virginica),
-    ((5.6, 2.5, 3.9, 1.1), Versicolor),
-    ((5.4, 3.9, 1.3, 0.4), Setosa),
-    ((5.5, 2.3, 4.0, 1.3), Versicolor),
-    ((6.4, 2.7, 5.3, 1.9), Virginica),
-    ((5.1, 3.5, 1.4, 0.3), Setosa),
-    ((5.5, 3.5, 1.3, 0.2), Setosa),
-    ((5.0, 3.2, 1.2, 0.2), Setosa),
-    ((5.1, 3.4, 1.5, 0.2), Setosa),
-    ((5.4, 3.9, 1.7, 0.4), Setosa),
-    ((4.5, 2.3, 1.3, 0.3), Setosa),
-    ((6.7, 3.0, 5.0, 1.7), Versicolor),
-    ((5.0, 3.3, 1.4, 0.2), Setosa),
-    ((7.1, 3.0, 5.9, 2.1), Virginica),
-    ((5.8, 2.6, 4.0, 1.2), Versicolor),
-    ((6.3, 2.7, 4.9, 1.8), Virginica),
-    ((6.8, 3.2, 5.9, 2.3), Virginica),
-    ((6.6, 3.0, 4.4, 1.4), Versicolor),
-    ((5.4, 3.4, 1.5, 0.4), Setosa),
-    ((5.0, 3.6, 1.4, 0.2), Setosa),
-    ((5.9, 3.2, 4.8, 1.8), Versicolor),
-    ((6.3, 2.5, 5.0, 1.9), Virginica),
-    ((6.0, 3.0, 4.8, 1.8), Virginica),
-    ((7.9, 3.8, 6.4, 2.0), Virginica),
-    ((5.9, 3.0, 4.2, 1.5), Versicolor),
-    ((4.8, 3.0, 1.4, 0.1), Setosa),
-    ((5.7, 2.8, 4.1, 1.3), Versicolor),
-    ((6.7, 2.5, 5.8, 1.8), Virginica),
-    ((5.7, 2.6, 3.5, 1.0), Versicolor),
-    ((4.4, 3.0, 1.3, 0.2), Setosa),
-    ((4.8, 3.4, 1.9, 0.2), Setosa),
-    ((6.3, 3.4, 5.6, 2.4), Virginica),
-    ((5.5, 4.2, 1.4, 0.2), Setosa),
-    ((5.0, 3.0, 1.6, 0.2), Setosa),
-    ((5.7, 2.9, 4.2, 1.3), Versicolor),
-    ((6.2, 2.8, 4.8, 1.8), Virginica),
-    ((6.2, 3.4, 5.4, 2.3), Virginica),
-    ((6.5, 3.0, 5.2, 2.0), Virginica),
-    ((4.9, 3.1, 1.5, 0.1), Setosa),
-    ((5.8, 2.7, 5.1, 1.9), Virginica),
-    ((5.1, 3.5, 1.4, 0.2), Setosa),
-    ((5.6, 2.8, 4.9, 2.0), Virginica),
-    ((5.5, 2.4, 3.7, 1.0), Versicolor),
-    ((6.1, 2.8, 4.0, 1.3), Versicolor),
-    ((5.7, 4.4, 1.5, 0.4), Setosa),
-    ((6.9, 3.1, 4.9, 1.5), Versicolor),
-    ((5.8, 2.8, 5.1, 2.4), Virginica),
-    ((5.7, 2.5, 5.0, 2.0), Virginica),
-    ((6.8, 2.8, 4.8, 1.4), Versicolor),
-    ((6.3, 2.9, 5.6, 1.8), Virginica),
-    ((6.0, 2.2, 4.0, 1.0), Versicolor),
-  ]
-
-irisTestData :: [((Float, Float, Float, Float), IrisClass)]
-irisTestData =
-    [
-
-    ]

src/IrisDataset.hs

@@ -12,19 +12,21 @@ module IrisDataset
   )
 where
 
+import qualified Data.ByteString.Lazy as B
+import Data.Csv
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import Data.Random
 import Data.Random.Distribution.Uniform
 import qualified Data.Text as T
 import Data.Tuple.Extra
+import qualified Debug.Trace as DB
 import GA
 import LambdaCalculus
 import IrisData
 import qualified Language.Haskell.Interpreter as Hint
 import qualified Language.Haskell.Interpreter.Unsafe as Hint
 import Protolude
-import Protolude.Error
 import qualified Type.Reflection as Ref
 
 irisLE :: LambdaEnviroment
@@ -35,9 +37,9 @@ irisLE =
           [ ((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float))), ["(+)", "(-)", "(*)"]),
             ((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Bool))), ["(>)", "(==)", "(>=)"]),
             ((Ref.SomeTypeRep (Ref.TypeRep @(IrisClass -> IrisClass -> Bool))), ["(==)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Float -> Float -> Float))), ["if'","if'","if'","if'","if'","if'","if'","if'"]),
+            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Float -> Float -> Float))), ["if'"]),
             ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> IrisClass -> IrisClass -> IrisClass))), ["if'","if'","if'","if'","if'","if'","if'","if'","if'","if'"])
+            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> IrisClass -> IrisClass -> IrisClass))), ["if'"])
           ],
       constants =
         Map.fromList
@@ -51,9 +53,9 @@ irisLE =
         ExpressionWeights
           { lambdaSpucker = 1,
             lambdaSchlucker = 1,
-            symbol = 30,
+            symbol = 1,
-            variable = 100,
+            variable = 2,
-            constant = 5
+            constant = 1
           }
     }
 
@@ -62,15 +64,14 @@ irisLEE =
   LamdaExecutionEnv
     { -- For now these need to define all available functions and types. Generic functions can be used.
       imports = ["IrisDataset"],
-      training = True,
+      -- Path to a CSV file containing the training dataset
+      trainingDataset = "./iris.csv",
+      -- Path to a CSV file containing the dataset results
+      trainingDatasetRes = "./res.csv",
       trainingData =
         ( map fst irisTrainingData,
           map snd irisTrainingData
         ),
-      testData =
-        ( map fst irisTestData,
-          map snd irisTestData
-        ),
       exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
       -- todo: kindaHacky
       results = Map.empty
@@ -79,9 +80,11 @@ irisLEE =
 data LamdaExecutionEnv = LamdaExecutionEnv
   { -- For now these need to define all available functions and types. Generic functions can be used.
     imports :: [Text],
-    training :: Bool,
+    -- Path to a CSV file containing the training dataset
+    trainingDataset :: FilePath,
+    -- Path to a CSV file containing the dataset results
+    trainingDatasetRes :: FilePath,
     trainingData :: ([(Float, Float, Float, Float)], [IrisClass]),
-    testData :: ([(Float, Float, Float, Float)], [IrisClass]),
     exTargetType :: TypeRep,
     -- todo: kindaHacky
     results :: Map TypeRequester FittnesRes
@@ -93,6 +96,7 @@ data FittnesRes = FittnesRes
     fitnessGeoMean :: R,
     fitnessMean :: R,
     accuracy :: Int,
+    biasDist :: R,
     biasSize :: R
   }
   deriving (Show)
@@ -107,11 +111,9 @@ instance Evaluator TypeRequester LamdaExecutionEnv FittnesRes where
     let toAdd = NE.filter (\k -> not (Map.member k (results env))) pop
     toInsert <- Hint.runInterpreter (evalResults env toAdd)
     let insertPair (key, val) m = Map.insert key val m
-    let res = foldr insertPair (results env) (fromRight (error ("To insert is " <> show toInsert)) toInsert)
+    let res = foldr insertPair (results env) (fromRight undefined toInsert)
     return env {results = res}
 
-dset :: LamdaExecutionEnv -> ([(Float, Float, Float, Float)], [IrisClass])
-dset lEE = if training lEE then trainingData lEE else testData lEE
 
 evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, FittnesRes)]
 evalResults ex trs = mapM (evalResult ex) trs
@@ -121,10 +123,11 @@ evalResult ex tr = do
   Hint.setImports $ (map T.unpack (imports ex)) ++ ["Protolude"]
   Hint.unsafeSetGhcOption "-O2"
   result <- Hint.interpret (T.unpack (toLambdaExpressionS tr)) (Hint.as :: Float -> Float -> Float -> Float -> IrisClass)
-  let res = map (\(a, b, c, d) -> result a b c d) (fst (dset ex))
+  let res = map (\(a, b, c, d) -> result a b c d) (fst (trainingData ex))
-  let resAndTarget = (zip (snd (dset ex)) res)
+  let resAndTarget = (zip (snd (trainingData ex)) res)
   let acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) :: Int
-  let biasSmall = exp ((-(fromIntegral (countTrsR tr)))/1000) -- 0 (schlecht) bis 1 (gut)
+  let biasWellDistributed = (foldr (*) 1 (map (\ty -> (foldr (\ts s -> if ((snd ts) == ty) then s + 1 else s) 1 resAndTarget)) ([minBound .. maxBound] :: [IrisClass]) :: [R])) ** (1 / 3) -- 1 (schlecht) bis 51 (gut)
+  let biasSmall = exp (-(fromIntegral (countTrsR tr))) -- 0 (schlecht) bis 1 (gut)
   let fitness' = meanOfAccuricyPerClass resAndTarget
   let score = fitness' + (biasSmall - 1)
   return
@@ -135,6 +138,7 @@ evalResult ex tr = do
           fitnessMean = meanOfAccuricyPerClass resAndTarget,
           fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
           accuracy = acc,
+          biasDist = biasWellDistributed,
           biasSize = biasSmall
         }
     )

src/LambdaCalculus.hs

@@ -9,7 +9,7 @@
 
 module LambdaCalculus where
 
-import Data.List (foldr1, last, nub, intersect, (!!), (\\))
+import Data.List (foldr1, last)
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import Data.Maybe
@@ -20,8 +20,6 @@ import Data.Typeable
 import GA
 import Pretty
 import Protolude
-import Protolude.Error
-import Debug.Trace as DB
 import Test.QuickCheck hiding (sample, shuffle)
 import Test.QuickCheck.Monadic (assert, monadicIO)
 import qualified Type.Reflection as Ref
@@ -94,8 +92,7 @@ toLambdaExpressionS :: TypeRequester -> Text
 toLambdaExpressionS (TR typeRep (Just lambdaExpression) boundVars) = "((" <> eToLambdaExpressionS lambdaExpression <> ") :: (" <> show typeRep <> "))"
 toLambdaExpressionS (TR _ (Nothing) _) = "Invalid Lambda Epr"
 
--- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show)
+-- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int | Constan ConVal
-
 
 eToLambdaExpressionS :: LambdaExpression -> Text
 eToLambdaExpressionS (LambdaSpucker typeRequester1 typeRequester2 boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionS typeRequester2 <> ") " <> toLambdaExpressionS typeRequester1
@@ -243,119 +240,53 @@ instance Environment TypeRequester LambdaEnviroment where
   nX _ = 3 -- todo!
 
   crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do
-    let trCount = countTrsR tr1
+    return Nothing
-    selectedIndex1 <- uniform 1 trCount
-    let (depthAt, selectedTr1@(TR _ _ bound1)) = depthLeftAndTypeAtR tr1 selectedIndex1 maxDepth
-    let indexes = findIndicesWhere tr2 (isCompatibleTr selectedTr1) 0
-    if length indexes == 0 then return Nothing else (do
-      (selectedTr2@(TR _ _ bound2),selectedIndex2) <- randomElement indexes
-      selectedTr2 <- adaptBoundVars selectedTr2 bound1
-      selectedTr1 <- adaptBoundVars selectedTr1 bound2
-      let child1 = replaceAtR selectedIndex1 tr1 selectedTr2
-      let child2 = replaceAtR selectedIndex2 tr2 selectedTr1
-      return $ Just (child1, child2)
-      )
 
+-- TODO: crossover!
+--  let trCount = countTrsR tr1
+--  selectedIndex1 <- uniform 1 trCount
+--  let (depthAt, selectedTr1@(TR trep _ bound)) = depthLeftAndTypeAtR tr selectedTR maxDepth
+--  let indexes = findIndicesWhere tr2 ( == trep)
+--  if length indexes == 0 then return Nothing else (do
+--    (selectedTr2,selectedIndex2) <- randomElement indexes)
 
 -- helper
-adaptBoundVars:: TypeRequester -> BoundVars -> RVar TypeRequester
-adaptBoundVars tr@(TR _ _ bvOld) bvNew = do
-  newIndexMap <- generateConversionIndexMap bvOld bvNew
-  return $ convertTr tr bvOld bvNew newIndexMap
 
-convertTr:: TypeRequester -> BoundVars -> BoundVars -> Map TypeRep (Int -> Int) -> TypeRequester
+-- findIndicesWhere:: TypeRequester -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)]
-convertTr tr@(TR tRp (Just le) bvCurr) bvOld bvNew mapper = TR tRp (Just (convertLe le bvOld bvNew mapper)) (bvNew ++ (bvCurr \\ bvOld))
+-- findIndicesWhere tr@(TR t lE _) filte indx = case lE of
-convertTr _ _ _ _ = error "le Not Just (convertTr)"
+--                            Just le -> (tr, indx+1):(findIndicesWhere' (asList le) filte (indx+1))
+--                            Nothing -> undefined
 
-
+-- findIndicesWhere':: [TypeRequester] -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)]
--- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show)
+-- findIndicesWhere' (tr:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr))
-convertLe:: LambdaExpression -> BoundVars -> BoundVars -> Map TypeRep (Int -> Int) -> LambdaExpression
-convertLe (LambdaSpucker tr1 tr2 bvCurr) bvOld bvNew mapper = LambdaSpucker (convertTrf tr1) (convertTrf tr2) (bvNew ++ (bvCurr \\ bvOld))
-  where convertTrf tr = convertTr tr bvOld bvNew mapper
-convertLe (LambdaSchlucker tr bvCurr) bvOld bvNew mapper = LambdaSchlucker (convertTrf tr) (bvNew ++ (bvCurr \\ bvOld))
-  where convertTrf tr = convertTr tr bvOld bvNew mapper
-convertLe (Symbol cv trs bvCurr) bvOld bvNew mapper = Symbol cv (map convertTrf trs) (bvNew ++ (bvCurr \\ bvOld))
-  where convertTrf tr = convertTr tr bvOld bvNew mapper
-convertLe (Var varType varNumber trs bvCurr) bvOld bvNew mapper = Var varType ((fromMaybe identity (Map.lookup varType mapper)) varNumber) (map convertTrf trs) (bvNew ++ (bvCurr \\ bvOld))
-  where convertTrf tr = convertTr tr bvOld bvNew mapper
-convertLe le@(Constan _) _ _ _ = le
-
-
-generateConversionIndexMap:: BoundVars -> BoundVars -> RVar (Map TypeRep (Int -> Int))
-generateConversionIndexMap bvOld bvNew = do
-  funcs <- mapM (\bT -> genMapper (count bvOld bT - 1) (count bvNew bT - 1)) (nub bvOld)
-  return $ Map.fromList $ zip (nub bvOld) funcs
-
-genMapper:: Int -> Int -> RVar (Int -> Int)
-genMapper i j | i == j = return identity
-              | i < j = return $ \int -> if int <= i then int else int + (j-i)
-              | i > j = do
-                  permutationForUnbound <- genPermutation i j
-                  return $ genMapperRandomAssment i j permutationForUnbound
-              | otherwise = error "impossible case in genMapper"
-
-genMapperRandomAssment:: Int -> Int -> [Int] -> Int -> Int
-genMapperRandomAssment i j permutationForUnbound int | int <= j = int
-                                                     | int > i = int - (i-j)
-                                                     | otherwise = permutationForUnbound !! (int - j - 1)
-
-genPermutation:: Int -> Int -> RVar [Int]
-genPermutation i j = replicateM (i - j) (uniform 0 j)
-
-isCompatibleTr:: TypeRequester -> TypeRequester -> Bool
-isCompatibleTr tr1@(TR trep1 _ bound1) tr2@(TR trep2 _ bound2) | trep1 == trep2 = allUsedBound (usedVars bound1 tr1) bound2 && allUsedBound (usedVars bound2 tr2) bound1
-                                                       | otherwise = False
-allUsedBound :: BoundVars -> BoundVars -> Bool
-allUsedBound used available = all (\x -> any (== x) available) used
-
-
-usedVars :: BoundVars -> TypeRequester -> BoundVars
-usedVars boundOld tr@(TR trep1 (Just (Var trp ind trs _)) _) = if any (== trp) boundOld && count boundOld trp > ind then trp : concatMap (usedVars boundOld) trs else concatMap (usedVars boundOld) trs
-usedVars boundOld tr@(TR trep1 (Just le) _) =  concatMap (usedVars boundOld) (asList le)
-usedVars _ _ = error "Nothing in usedVars"
-
-
-boundsConvertable:: BoundVars -> BoundVars -> Bool
-boundsConvertable bv1 bv2 =  length (nub bv2) == length (nub bv1) && length (intersect (nub bv1) bv2) == length (nub bv1)
-
-
-findIndicesWhere:: TypeRequester -> (TypeRequester -> Bool) -> Int -> [(TypeRequester, Int)]
-findIndicesWhere tr@(TR t lE _) filte indx = case lE of
-                           Just le -> if filte tr then (tr, indx+1):(findIndicesWhere' (asList le) filte (indx+1)) else (findIndicesWhere' (asList le) filte (indx+1))
-                           Nothing -> error "Nothing in findIndicesWhere"
-
-findIndicesWhere':: [TypeRequester] -> (TypeRequester -> Bool) -> Int -> [(TypeRequester, Int)]
-findIndicesWhere' [] _ _ = []
-findIndicesWhere' [tr] f indx = (findIndicesWhere tr f indx)
-findIndicesWhere' (tr:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr))
 
 replaceAtR :: Int -> TypeRequester -> TypeRequester -> TypeRequester
 replaceAtR 1 _ with = with
 replaceAtR i (TR tm (Just le) bV) with = TR tm (Just (replaceAt (i - 1) le with)) bV
-replaceAtR _ (TR _ Nothing _) _ = error "Nothing in replaceAtR"
+replaceAtR _ (TR _ Nothing _) _ = undefined
 
 replaceAt :: Int -> LambdaExpression -> TypeRequester -> LambdaExpression
 replaceAt i le@(LambdaSpucker _ _ bv) with = LambdaSpucker (fromJust (head trs)) (last trs) bv where trs = replaceInSubtreeWithIndex i (asList le) with
 replaceAt i (LambdaSchlucker tr bv) with = LambdaSchlucker (replaceAtR i tr with) bv
 replaceAt i le@(Symbol cv _ bv) with = Symbol cv trs bv where trs = replaceInSubtreeWithIndex i (asList le) with
 replaceAt i le@(Var tr ix _ bv) with = Var tr ix trs bv where trs = replaceInSubtreeWithIndex i (asList le) with
-replaceAt _ (Constan _) _ = error "Nothing in replaceAt"
+replaceAt _ (Constan _) _ = undefined
 
 replaceInSubtreeWithIndex :: Int -> [TypeRequester] -> TypeRequester -> [TypeRequester]
 replaceInSubtreeWithIndex indexLeft (tr : trs) with = if countTrsR tr >= indexLeft then (replaceAtR indexLeft tr with) : trs else tr : (replaceInSubtreeWithIndex (indexLeft - countTrsR tr) trs with)
-replaceInSubtreeWithIndex _ [] _ = error "Index not found in replaceInSubtreeWithIndex"
+replaceInSubtreeWithIndex _ [] _ = undefined
 
 depthLeftAndTypeAtR :: TypeRequester -> Int -> Int -> (Int, TypeRequester)
 depthLeftAndTypeAtR t 1 depthLeft = ((depthLeft - 1), t)
 depthLeftAndTypeAtR (TR _ (Just le) _) indexLeft depthLeft = depthLeftAndTypeAt le (indexLeft - 1) (depthLeft - 1)
-depthLeftAndTypeAtR (TR _ Nothing _) indexLeft depthLeft = error "Nothing in depthLeftAndTypeAtR"
+depthLeftAndTypeAtR (TR _ Nothing _) indexLeft depthLeft = undefined
 
 depthLeftAndTypeAt :: LambdaExpression -> Int -> Int -> (Int, TypeRequester)
 depthLeftAndTypeAt le indexLeft depthLeft = depthLeftAndTypeInSubtreeWithIndex (asList le) indexLeft depthLeft
 
 depthLeftAndTypeInSubtreeWithIndex :: [TypeRequester] -> Int -> Int -> (Int, TypeRequester)
 depthLeftAndTypeInSubtreeWithIndex (tr : trs) indexLeft depthLeft = if countTrsR tr >= indexLeft then depthLeftAndTypeAtR tr indexLeft depthLeft else depthLeftAndTypeInSubtreeWithIndex trs (indexLeft - countTrsR tr) depthLeft
-depthLeftAndTypeInSubtreeWithIndex [] indexLeft depthLeft = error "Index not found in depthLeftAndTypeInSubtreeWithIndex"
+depthLeftAndTypeInSubtreeWithIndex [] indexLeft depthLeft = undefined
 
 countTrsR :: TypeRequester -> Int
 countTrsR tr@(TR t lE _) = case lE of

src/Main.hs

@@ -10,8 +10,6 @@ import System.IO
 -- import Szenario212Pun
 -- import Szenario191
 import IrisDataset
-import Debug.Trace as DB
-import qualified Data.Map.Strict as Map
 
 data Options = Options
   { iterations :: !N,
@@ -26,7 +24,7 @@ options =
       ( long "iterations"
           <> short 'i'
           <> metavar "N"
-          <> value 500
+          <> value 1000
           <> help "Number of iterations"
       )
     <*> option
@@ -34,7 +32,7 @@ options =
       ( long "population-size"
           <> short 'p'
           <> metavar "N"
-          <> value 100
+          <> value 50
           <> help "Population size"
       )
 
@@ -54,12 +52,12 @@ main =
     let env = irisLE
     let selType = Tournament 3
     let run' = run irisLEE env selType 40 (5 / 100) (populationSize opts) (steps (iterations opts))
-    pop' <- runEffect (for run' logCsv)
+    pop' <-
-    irisLEE' <- calc irisLEE  pop'
+      runEffect (for run' logCsv)
-    let (res, _) = bests irisLEE' 5 pop'
+
-    let irisLEE' = irisLEE {training = False}
+    irisLE <- calc irisLEE  pop'
-    irisLEE' <- calc irisLEE' res
+    let (res, _) = bests irisLE 5 pop'
-    mapM_ (format irisLEE') res
+    mapM_ (format irisLE) res
   where
     format irisL s = do
       let f = fitness' irisL s