split of dataset

build.sbatch

@@ -1,9 +0,0 @@
-#!/usr/bin/env bash
-#SBATCH --time=00:10:00
-#SBATCH --partition=cpu
-#SBATCH --output=./output/output_build.txt
-#SBATCH --error=./output/error_build.txt
-#SBATCH --nodelist=oc-compute02
-#SBATCH --mem=4G
-#SBATCH -c16
-srun nix develop --command stack --no-nix --system-ghc --no-install-ghc build

flake.lock

@@ -2,17 +2,17 @@
   "nodes": {
     "nixpkgs": {
       "locked": {
-        "lastModified": 1713145326,
+        "lastModified": 1655624069,
-        "narHash": "sha256-m7+IWM6mkWOg22EC5kRUFCycXsXLSU7hWmHdmBfmC3s=",
+        "narHash": "sha256-7g1zwTdp35GMTERnSzZMWJ7PG3QdDE8VOX3WsnOkAtM=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "53a2c32bc66f5ae41a28d7a9a49d321172af621e",
+        "rev": "0d68d7c857fe301d49cdcd56130e0beea4ecd5aa",
         "type": "github"
       },
       "original": {
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "53a2c32bc66f5ae41a28d7a9a49d321172af621e",
+        "rev": "0d68d7c857fe301d49cdcd56130e0beea4ecd5aa",
         "type": "github"
       }
     },

flake.nix

@@ -2,7 +2,8 @@
   description = "Flake for haga";
   inputs = {
     nixpkgs.url =
-      "github:NixOS/nixpkgs/53a2c32bc66f5ae41a28d7a9a49d321172af621e";
+      # 2022-06-22
+      "github:NixOS/nixpkgs/0d68d7c857fe301d49cdcd56130e0beea4ecd5aa";
 
   };
 
@@ -13,12 +14,10 @@
       # defaultPackage.${system} = haskellPackages.callPackage ./default.nix { };
       devShell.${system} = mkShell {
         buildInputs = [
-          haskell.compiler.ghc981
-          git
-          gcc
-          gmp
           feedgnuplot
-          stack
+          haskellPackages.cabal-install
+          haskellPackages.ormolu
+          haskell.compiler.ghc8107
         ];
       };
     };

haga.cabal

@@ -1,4 +1,4 @@
-cabal-version:       3.4
+cabal-version:       2.2
 name:                haga
 version:             0.1.0.0
 synopsis:            Simplistic genetic algorithms library
@@ -30,7 +30,6 @@ library
                      , MonadRandom
                      , mwc-random
                      , optparse-applicative
-                     , parallel
                      , path
                      , pipes
                      , primitive
@@ -43,30 +42,27 @@ library
                      , text
                      , wl-pprint-text
   default-language:    Haskell2010
-  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans -O2
+  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
-  hs-source-dirs:      lib, lambda/lib
+  hs-source-dirs:      src
-  other-modules:       CommonDefinition
   exposed-modules:     GA
-                     , LambdaCalculus
+                     , Seminar
                      , Pretty
-                     , Utils
+                     , Szenario191
-                     , LambdaDatasets.NurseryDefinition
+                     , LambdaCalculus
-                     , LambdaDatasets.GermanDefinition
+                     , IrisDataset
-                     , LambdaDatasets.IrisDefinition
+                     , IrisData
 
-executable haga-lambda
+executable haga
   build-depends:       base
                      , bytestring
                      , cassava
                      , containers
                      , extra
                      , hint
-                     , haga
                      , monad-loops
                      , MonadRandom
                      , mwc-random
                      , optparse-applicative
-                     , parallel
                      , path
                      , pipes
                      , primitive
@@ -80,32 +76,15 @@ executable haga-lambda
                      , wl-pprint-text
   default-language:    Haskell2010
   ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
-  hs-source-dirs:      lambda/src
+  hs-source-dirs:      src
   main-is:             Main.hs
-  other-modules:       LambdaDatasets.NurseryDataset
+  other-modules:       GA
-                     , LambdaDatasets.NurseryData
+                     , Seminar
-                     , LambdaDatasets.GermanDataset
+                     , Pretty
-                     , LambdaDatasets.GermanData
-                     , LambdaDatasets.IrisDataset
-                     , LambdaDatasets.IrisData
-
-executable haga-students
-  build-depends:       base
-                     , extra
-                     , haga
-                     , optparse-applicative
-                     , protolude
-                     , pipes
-                     , QuickCheck
-                     , quickcheck-instances
-                     , random-fu
-                     , text
-  default-language:    Haskell2010
-  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
-  hs-source-dirs:      src-students
-  main-is:             Main.hs
-  other-modules:       Seminar
                      , Szenario191
+                     , LambdaCalculus
+                     , IrisDataset
+                     , IrisData
 
 executable haga-test
   build-depends:       base
@@ -114,13 +93,11 @@ executable haga-test
                      , cassava
                      , containers
                      , extra
-                     , haga
                      , hint
                      , monad-loops
                      , MonadRandom
                      , mwc-random
                      , optparse-applicative
-                     , parallel
                      , path
                      , pipes
                      , primitive
@@ -134,5 +111,12 @@ executable haga-test
                      , wl-pprint-text
   default-language:    Haskell2010
   ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
-  hs-source-dirs:      lib
+  hs-source-dirs:      src
   main-is:             Test.hs
+  other-modules:       GA
+                     , Seminar
+                     , Pretty
+                     , Szenario191
+                     , LambdaCalculus
+                     , IrisDataset
+                     , IrisData

lambda/README.md

@@ -1,17 +0,0 @@
-# Why this split:
-
-
-The Module(s) used when evaluating individuals has to be in an external library to make Hint work. so we split the lamda-calculus command program in a library we need to expose in the main library and the implementation.
-
-Sadly, ghc / ghci / cabal can not properly make a public, internal library available to ghci (and, with that, Hint). Should this ever change:
-```
-library haga-lambda-lib
-  visibility:          public
-  build-depends:       base
-                     , protolude
-  default-language:    Haskell2010
-  ghc-options:         -Wall -Wno-orphans -O2
-  hs-source-dirs:      lambda/lib
-  other-modules:       CommonDefinition
-  exposed-modules:     LambdaDatasets.NurseryDefinition
-```

lambda/lib/CommonDefinition.hs

@@ -1,9 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module CommonDefinition where
-
-import Protolude
-
-if' :: Bool -> a -> a -> a
-if' True e _ = e
-if' False _ e = e

lambda/lib/LambdaDatasets/GermanDefinition.hs

@@ -1,38 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module LambdaDatasets.GermanDefinition
-  ( module LambdaDatasets.GermanDefinition,
-    module CommonDefinition,
-  ) where
-
-
-import Protolude
-import CommonDefinition
-
-data GermanClass = Accept | Deny deriving (Eq, Generic, Show, Enum, Bounded)
-
-data AccountStatus = AccountInDebt | NoAccount | LowAccountBalance | HighAccountBalanceOrRegular deriving (Eq, Generic, Show, Enum, Bounded, Ord)
-
-data CreditHistory = HistoryGood | HistoryGoodHere | HistoryGoodSoFar | DelaysInHistory | CreditsExist deriving (Eq, Generic, Show, Enum, Bounded, Ord)
-
-data Purpose = OldCar | NewCar | FunitureOrEquipment | Tech | Appliances | Repairs | Education | Retraining | Business | Other deriving (Eq, Generic, Show, Enum, Bounded)
-
-data Savings = UnknownOrNone | SmallSavings | NormalSavings | GoodSavings | GreatSavings deriving (Eq, Generic, Show, Enum, Bounded, Ord)
-
-data EmploymentStatus = NotEmployed | ShortTermEmployed | MediumTermEmployed | LongTermEmployed | VeteranEmployed deriving (Eq, Generic, Show, Enum, Bounded, Ord)
-
-data StatusAndSex = MaleAndSeperated | FemaleAndSeperatedOrMarried | MaleAndSingle | FemaleAndSingle | MaleAndWidowedOrMarried deriving (Eq, Generic, Show, Enum, Bounded)
-
-data OtherDebtors = NoOtherDebtors | CoApplicant | Guarantor deriving (Eq, Generic, Show, Enum, Bounded, Ord)
-
-data Property = UnknownOrNoProperty | RealEstate | Savings | CarOrOther deriving (Eq, Generic, Show, Enum, Bounded)
-
-data OtherPlans = PlansAtBank | PlansAtStores | NoOtherPlans deriving (Eq, Generic, Show, Enum, Bounded)
-
-data Housing = Renting | OwningRecidency | ResidingForFree deriving (Eq, Generic, Show, Enum, Bounded)
-
-data Job = UnemployedOrUnskilledNonResident | UnskilledResident | Skilled | HighlySkilled deriving (Eq, Generic, Show, Enum, Bounded, Ord)

lambda/lib/LambdaDatasets/IrisDefinition.hs

@@ -1,16 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module LambdaDatasets.IrisDefinition
-  ( module LambdaDatasets.IrisDefinition,
-    module CommonDefinition,
-  ) where
-
-import Protolude
-import CommonDefinition
-
-data IrisClass = Setosa | Virginica | Versicolor deriving (Eq, Generic, Show, Enum, Bounded)
-

lambda/lib/LambdaDatasets/NurseryDefinition.hs

@@ -1,32 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module LambdaDatasets.NurseryDefinition
-  ( module LambdaDatasets.NurseryDefinition,
-    module CommonDefinition,
-  ) where
-
-import Protolude
-import CommonDefinition
-
-data NurseryClass = NotRecommend | Recommend | VeryRecommend | Priority | SpecPriority deriving (Eq, Generic, Show, Enum, Bounded, Ord)
-
-data Parents = Usual | Pretentious | GreatPret deriving (Eq, Generic, Show, Enum, Bounded, Ord)
-
-data HasNurs = ProperNurs | LessProperNurs | ImproperNurs | CriticalNurs | VeryCritNurs deriving (Eq, Generic, Show, Enum, Bounded, Ord)
-
-data Form    = CompleteFamilyForm | CompletedFamilyForm | IncompleteFamilyForm | FosterFamilyForm deriving (Eq, Generic, Show, Enum, Bounded, Ord)
-
-data Children = OneChild | TwoChilds | ThreeChilds | MoreChilds deriving (Eq, Generic, Show, Enum, Bounded, Ord)
-
-data Housing = ConvenientHousing | LessConvHousing | CriticalHousing deriving (Eq, Generic, Show, Enum, Bounded, Ord)
-
-data Finance = ConvenientFinance | InconvFinance deriving (Eq, Generic, Show, Enum, Bounded, Ord)
-
-data Social = NotProblematicSocial | SlightlyProblematicSocial | ProblematicSocial deriving (Eq, Generic, Show, Enum, Bounded, Ord)
-
-data Health = NotRecommendHealth |RecommendedHealth | PriorityHealth  deriving (Eq, Generic, Show, Enum, Bounded, Ord)
-

lambda/src/LambdaDatasets/GermanDataset.hs

@@ -1,208 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module LambdaDatasets.GermanDataset
-  ( module LambdaCalculus,
-    module LambdaDatasets.GermanDataset,
-    module LambdaDatasets.GermanData,
-    module GA,
-  )
-where
-
-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 GA
-import LambdaDatasets.GermanData
-import LambdaCalculus
-import qualified Language.Haskell.Interpreter as Hint
-import qualified Language.Haskell.Interpreter.Unsafe as Hint
-import Protolude
-import Protolude.Error
-import System.Random.MWC (createSystemRandom)
-import qualified Type.Reflection as Ref
-import Utils
-
-lE :: LambdaEnviroment
-lE =
-  LambdaEnviroment
-    { functions =
-        Map.fromList
-          [ -- Math
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int))), ["(+)", "(-)", "(*)"]),
-            -- Logic
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
-            -- Ordered
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(AccountStatus -> AccountStatus -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(CreditHistory -> CreditHistory -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Savings -> Savings -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(EmploymentStatus -> EmploymentStatus -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(OtherDebtors -> OtherDebtors -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Job -> Job -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            -- Eq
-            ((Ref.SomeTypeRep (Ref.TypeRep @(GermanClass -> GermanClass -> Bool))), ["(==)", "(/=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Purpose -> Purpose -> Bool))), ["(==)", "(/=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(StatusAndSex -> StatusAndSex -> Bool))), ["(==)", "(/=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Property -> Property -> Bool))), ["(==)", "(/=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(OtherPlans -> OtherPlans -> Bool))), ["(==)", "(/=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Housing -> Housing -> Bool))), ["(==)", "(/=)"]),
-            -- Any Type
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Int -> Int -> Int))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> GermanClass -> GermanClass -> GermanClass))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> AccountStatus -> AccountStatus -> AccountStatus))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> CreditHistory -> CreditHistory -> CreditHistory))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Purpose -> Purpose -> Purpose))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Savings -> Savings -> Savings))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> EmploymentStatus -> EmploymentStatus -> EmploymentStatus))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> StatusAndSex -> StatusAndSex -> StatusAndSex))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> OtherDebtors -> OtherDebtors -> OtherDebtors))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Property -> Property -> Property))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> OtherPlans -> OtherPlans -> OtherPlans))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Housing -> Housing -> Housing))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Job -> Job -> Job))), ["if'"])
-          ],
-      constants =
-        Map.fromList
-          [ ((Ref.SomeTypeRep (Ref.TypeRep @(Int))), [(fmap show (uniform 0 10 :: RVar Int))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool))), [(fmap show (uniform True False :: RVar Bool))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(GermanClass))), [(fmap show (enumUniform Accept Deny))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(AccountStatus))), [(fmap show (enumUniform AccountInDebt HighAccountBalanceOrRegular))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(CreditHistory))), [(fmap show (enumUniform HistoryGood CreditsExist ))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Purpose))), [(fmap show (enumUniform OldCar Other ))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Savings))), [(fmap show (enumUniform UnknownOrNone GreatSavings ))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(EmploymentStatus))), [(fmap show (enumUniform NotEmployed VeteranEmployed ))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(StatusAndSex))), [(fmap show (enumUniform MaleAndSeperated MaleAndWidowedOrMarried ))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(OtherDebtors))), [(fmap show (enumUniform NoOtherDebtors Guarantor ))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Property))), [(fmap show (enumUniform UnknownOrNoProperty CarOrOther ))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(OtherPlans))), [(fmap show (enumUniform PlansAtBank NoOtherPlans ))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Housing))), [(fmap show (enumUniform Renting ResidingForFree ))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Job))), [(fmap show (enumUniform UnemployedOrUnskilledNonResident HighlySkilled ))])
-          ],
-      targetType = (Ref.SomeTypeRep (Ref.TypeRep @(AccountStatus -> Int -> CreditHistory -> Purpose -> Int -> Savings -> EmploymentStatus -> Int -> StatusAndSex -> OtherDebtors -> Int -> Property -> Int -> OtherPlans -> Housing -> Int -> Job -> Int -> Bool -> Bool -> GermanClass))),
-      maxDepth = 9,
-      weights =
-        ExpressionWeights
-          { lambdaSpucker = 0,
-            lambdaSchlucker = 10,
-            symbol = 100,
-            variable = 5,
-            constant = 5
-          }
-    }
-
-lEE :: LamdaExecutionEnv
-lEE =
-  LamdaExecutionEnv
-    { -- For now these need to define all available functions and types. Generic functions can be used.
-      imports = ["LambdaDatasets.GermanDefinition"],
-      training = True,
-      trainingData =
-        ( map fst (takeFraktion 0.8 germanTrainingData),
-          map snd (takeFraktion 0.8 germanTrainingData)
-        ),
-      testData =
-        ( map fst (dropFraktion 0.8 germanTrainingData),
-          map snd (dropFraktion 0.8 germanTrainingData)
-        ),
-      exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(AccountStatus -> Int -> CreditHistory -> Purpose -> Int -> Savings -> EmploymentStatus -> Int -> StatusAndSex -> OtherDebtors -> Int -> Property -> Int -> OtherPlans -> Housing -> Int -> Job -> Int -> Bool -> Bool -> GermanClass))),
-      results = Map.empty
-    }
-
-shuffledLEE :: IO LamdaExecutionEnv
-shuffledLEE = do
-  mwc <- liftIO createSystemRandom
-  let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
-  itD <- smpl $ shuffle germanTrainingData
-  return
-    LamdaExecutionEnv
-      { -- For now these need to define all available functions and types. Generic functions can be used.
-        imports = ["LambdaDatasets.GermanDefinition"],
-        training = True,
-        trainingData =
-          ( map fst (takeFraktion 0.8 itD),
-            map snd (takeFraktion 0.8 itD)
-          ),
-        testData =
-          ( map fst (dropFraktion 0.8 itD),
-            map snd (dropFraktion 0.8 itD)
-          ),
-        exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(AccountStatus -> Int -> CreditHistory -> Purpose -> Int -> Savings -> EmploymentStatus -> Int -> StatusAndSex -> OtherDebtors -> Int -> Property -> Int -> OtherPlans -> Housing -> Int -> Job -> Int -> Bool -> Bool -> GermanClass))),
-        results = Map.empty
-      }
-
-data LamdaExecutionEnv = LamdaExecutionEnv
-  { -- For now these need to define all available functions and types. Generic functions can be used.
-    imports :: [Text],
-    training :: Bool,
-    trainingData :: ([(AccountStatus, Int, CreditHistory, Purpose, Int, Savings, EmploymentStatus, Int, StatusAndSex, OtherDebtors, Int, Property, Int, OtherPlans, Housing, Int, Job, Int, Bool, Bool)], [GermanClass]),
-    testData :: ([(AccountStatus, Int, CreditHistory, Purpose, Int, Savings, EmploymentStatus, Int, StatusAndSex, OtherDebtors, Int, Property, Int, OtherPlans, Housing, Int, Job, Int, Bool, Bool)], [GermanClass]),
-    exTargetType :: TypeRep,
-    -- todo: kindaHacky
-    results :: Map TypeRequester FittnesRes
-  }
-
-data FittnesRes = FittnesRes
-  { total :: R,
-    fitnessTotal :: R,
-    fitnessGeoMean :: R,
-    fitnessMean :: R,
-    accuracy :: R,
-    biasSize :: R,
-    totalSize :: N
-  }
-  deriving (Show)
-
-instance Fitness FittnesRes where
-  getR = total
-
-instance Evaluator TypeRequester LamdaExecutionEnv FittnesRes where
-  fitness' env tr = (results env) Map.! tr
-
-  calc env pop = do
-    let relevantResults = Map.filterWithKey (\k _ -> contains pop k) (results env)
-    let toAdd = NE.filter (\k -> not (Map.member k relevantResults)) pop
-    toInsert <- Hint.runInterpreter (evalResults env toAdd)
-    let insertPair (key, val) m = Map.insert key val m
-    let res = foldr insertPair relevantResults (fromRight (error ("To insert is " <> show toInsert)) toInsert)
-    return env {results = res}
-
-dset :: LamdaExecutionEnv -> ([(AccountStatus, Int, CreditHistory, Purpose, Int, Savings, EmploymentStatus, Int, StatusAndSex, OtherDebtors, Int, Property, Int, OtherPlans, Housing, Int, Job, Int, Bool, Bool)], [GermanClass])
-dset lEE = if training lEE then trainingData lEE else testData lEE
-
-evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, FittnesRes)]
-evalResults ex trs = do
-  Hint.setImports $ (map T.unpack (imports ex)) ++ ["Protolude"]
-  Hint.unsafeSetGhcOption "-O2"
-  let arrayOfFunctionText = map toLambdaExpressionS trs
-  let textOfFunctionArray = "[" <> T.intercalate "," arrayOfFunctionText <> "]"
-  result <- Hint.interpret (T.unpack (textOfFunctionArray)) (Hint.as :: [AccountStatus -> Int -> CreditHistory -> Purpose -> Int -> Savings -> EmploymentStatus -> Int -> StatusAndSex -> OtherDebtors -> Int -> Property -> Int -> OtherPlans -> Housing -> Int -> Job -> Int -> Bool -> Bool -> GermanClass])
-  return $ zipWith (evalResult ex) trs result
-
-
-evalResult :: LamdaExecutionEnv -> TypeRequester -> (AccountStatus -> Int -> CreditHistory -> Purpose -> Int -> Savings -> EmploymentStatus -> Int -> StatusAndSex -> OtherDebtors -> Int -> Property -> Int -> OtherPlans -> Housing -> Int -> Job -> Int -> Bool -> Bool -> GermanClass) -> (TypeRequester, FittnesRes)
-evalResult ex tr result = ( tr,
-      FittnesRes
-        { total = acc * 100 + (biasSmall - 1),
-          fitnessTotal = fitness',
-          fitnessMean = meanOfAccuricyPerClass resAndTarget,
-          fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
-          accuracy = acc,
-          biasSize = biasSmall,
-          totalSize = countTrsR tr
-        }
-    )
-    where
-    res = map (\(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) -> result a b c d e f g h i j k l m n o p q r s t) (fst (dset ex))
-    resAndTarget = (zip (snd (dset ex)) res)
-    acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) / fromIntegral (length resAndTarget)
-    biasSmall = exp ((-(fromIntegral (countTrsR tr))) / 1000) -- 0 (schlecht) bis 1 (gut)
-    fitness' = meanOfAccuricyPerClass resAndTarget
-    score = fitness' + (biasSmall - 1)
-

lambda/src/LambdaDatasets/IrisData.hs

@@ -1,168 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module LambdaDatasets.IrisData
-  ( module LambdaDatasets.IrisDefinition,
-    module LambdaDatasets.IrisData,
-  )
-where
-
-import LambdaDatasets.IrisDefinition
-import Protolude
-
-irisTrainingData :: [((Float, Float, Float, Float), IrisClass)]
-irisTrainingData =
-  [ ((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),
-    ((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)
-  ]

lambda/src/LambdaDatasets/IrisDataset.hs

@@ -1,173 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module LambdaDatasets.IrisDataset
-  ( module LambdaCalculus,
-    module LambdaDatasets.IrisDataset,
-    module LambdaDatasets.IrisData,
-    module GA,
-  )
-where
-
-import qualified Data.List.NonEmpty as NE
-import qualified Data.Map.Strict as Map
-import Data.Random
-import System.Random.MWC (createSystemRandom)
-import Data.Random.Distribution.Uniform
-import qualified Data.Text as T
-import Data.Tuple.Extra
-import GA
-import LambdaCalculus
-import LambdaDatasets.IrisData
-import qualified Language.Haskell.Interpreter as Hint
-import qualified Language.Haskell.Interpreter.Unsafe as Hint
-import Protolude
-import Utils
-import Protolude.Error
-import qualified Type.Reflection as Ref
-
-lE :: LambdaEnviroment
-lE =
-  LambdaEnviroment
-    { functions =
-        Map.fromList
-          [  -- Math
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float))), ["(+)", "(-)", "(*)"]),
-            -- Logic
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
-            -- Ordered
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            -- Eq
-            ((Ref.SomeTypeRep (Ref.TypeRep @(IrisClass -> IrisClass -> Bool))), ["(==)","(/=)"]),
-            -- Any Type
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Float -> Float -> Float))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> IrisClass -> IrisClass -> IrisClass))), ["if'"])
-          ],
-      constants =
-        Map.fromList
-          [ ((Ref.SomeTypeRep (Ref.TypeRep @(Float))), [(fmap show (uniform 0 10 :: RVar Float))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool))), [(fmap show (uniform True False :: RVar Bool))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(IrisClass))), [(fmap show (enumUniform Setosa Versicolor :: RVar IrisClass))])
-          ],
-      targetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
-      maxDepth = 9,
-      weights =
-        ExpressionWeights
-          { lambdaSpucker = 0,
-            lambdaSchlucker = 10,
-            symbol = 100,
-            variable = 5,
-            constant = 5
-          }
-    }
-
-lEE :: LamdaExecutionEnv
-lEE =
-  LamdaExecutionEnv
-    { -- For now these need to define all available functions and types. Generic functions can be used.
-      imports = ["LambdaDatasets.IrisDefinition"],
-      training = True,
-      trainingData =
-        ( map fst (takeFraktion 0.8 irisTrainingData),
-          map snd (takeFraktion 0.8 irisTrainingData)
-        ),
-      testData =
-        ( map fst (dropFraktion 0.8 irisTrainingData),
-          map snd (dropFraktion 0.8 irisTrainingData)
-        ),
-      exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
-      results = Map.empty
-    }
-
-shuffledLEE :: IO LamdaExecutionEnv
-shuffledLEE = do
-  mwc <- liftIO createSystemRandom
-  let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
-  itD <- smpl $ shuffle irisTrainingData
-  return  LamdaExecutionEnv
-    { -- For now these need to define all available functions and types. Generic functions can be used.
-      imports = ["LambdaDatasets.IrisDefinition"],
-      training = True,
-      trainingData =
-        ( map fst (takeFraktion 0.8 itD),
-          map snd (takeFraktion 0.8 itD)
-        ),
-      testData =
-        ( map fst (dropFraktion 0.8 itD),
-          map snd (dropFraktion 0.8 itD)
-        ),
-      exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
-      results = Map.empty
-    }
-
-data LamdaExecutionEnv = LamdaExecutionEnv
-  { -- For now these need to define all available functions and types. Generic functions can be used.
-    imports :: [Text],
-    training :: Bool,
-    trainingData :: ([(Float, Float, Float, Float)], [IrisClass]),
-    testData :: ([(Float, Float, Float, Float)], [IrisClass]),
-    exTargetType :: TypeRep,
-    -- todo: kindaHacky
-    results :: Map TypeRequester FittnesRes
-  }
-
-data FittnesRes = FittnesRes
-  { total :: R,
-    fitnessTotal :: R,
-    fitnessGeoMean :: R,
-    fitnessMean :: R,
-    accuracy :: R,
-    biasSize :: R,
-    totalSize :: N
-  }
-  deriving (Show)
-
-instance Fitness FittnesRes where
-  getR = total
-
-instance Evaluator TypeRequester LamdaExecutionEnv FittnesRes where
-  fitness' env tr = (results env) Map.! tr
-
-  calc env pop = do
-    let relevantResults = Map.filterWithKey (\k _ -> contains pop k) (results env)
-    let toAdd = NE.filter (\k -> not (Map.member k relevantResults)) pop
-    toInsert <- Hint.runInterpreter (evalResults env toAdd)
-    let insertPair (key, val) m = Map.insert key val m
-    let res = foldr insertPair relevantResults (fromRight (error ("To insert is " <> show toInsert)) 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 = do
-  Hint.setImports $ (map T.unpack (imports ex)) ++ ["Protolude"]
-  Hint.unsafeSetGhcOption "-O2"
-  let arrayOfFunctionText = map toLambdaExpressionS trs
-  let textOfFunctionArray = "[" <> T.intercalate "," arrayOfFunctionText <> "]"
-  result <- Hint.interpret (T.unpack (textOfFunctionArray)) (Hint.as :: [Float -> Float -> Float -> Float -> IrisClass])
-  return $ zipWith (evalResult ex) trs result
-
-
-evalResult :: LamdaExecutionEnv -> TypeRequester -> (Float -> Float -> Float -> Float -> IrisClass) -> (TypeRequester, FittnesRes)
-evalResult ex tr result = ( tr,
-      FittnesRes
-        { total = acc * 100 + (biasSmall - 1),
-          fitnessTotal = fitness',
-          fitnessMean = meanOfAccuricyPerClass resAndTarget,
-          fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
-          accuracy = acc,
-          biasSize = biasSmall,
-          totalSize = countTrsR tr
-        }
-    )
-    where
-    res = map (\(a, b, c, d) -> result a b c d) (fst (dset ex))
-    resAndTarget = (zip (snd (dset ex)) res)
-    acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) / fromIntegral (length resAndTarget)
-    biasSmall = exp ((-(fromIntegral (countTrsR tr))) / 1000) -- 0 (schlecht) bis 1 (gut)
-    fitness' = meanOfAccuricyPerClass resAndTarget
-    score = fitness' + (biasSmall - 1)

lambda/src/LambdaDatasets/NurseryDataset.hs

@@ -1,199 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module LambdaDatasets.NurseryDataset
-  ( module LambdaCalculus,
-    module LambdaDatasets.NurseryDataset,
-    module LambdaDatasets.NurseryData,
-    module GA,
-  )
-where
-
-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 GA
-import LambdaDatasets.NurseryData
-import LambdaCalculus
-import qualified Language.Haskell.Interpreter as Hint
-import qualified Language.Haskell.Interpreter.Unsafe as Hint
-import Protolude
-import Protolude.Error
-import System.Random.MWC (createSystemRandom)
-import qualified Type.Reflection as Ref
-import Utils
-
-lE :: LambdaEnviroment
-lE =
-  LambdaEnviroment
-    { functions =
-        Map.fromList
-          [ -- Math
-            -- Logic
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
-            -- Ordered
-            ((Ref.SomeTypeRep (Ref.TypeRep @(NurseryClass -> NurseryClass -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Parents -> Parents -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(HasNurs -> HasNurs -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Form -> Form -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Children -> Children -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Housing -> Housing -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Finance -> Finance -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Social -> Social -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Health -> Health -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            -- Eq
-            -- Any Type
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Int -> Int -> Int))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> NurseryClass -> NurseryClass -> NurseryClass))), ["if'","if'","if'","if'","if'","if'","if'","if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Parents -> Parents -> Parents))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> HasNurs -> HasNurs -> HasNurs))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Form -> Form -> Form))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Children -> Children -> Children))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Housing -> Housing -> Housing))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Finance -> Finance -> Finance))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Social -> Social -> Social))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Health -> Health -> Health))), ["if'"])
-          ],
-      constants =
-        Map.fromList
-          [ ((Ref.SomeTypeRep (Ref.TypeRep @(Bool))), [(fmap show (uniform True False :: RVar Bool))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(NurseryClass))), [(fmap show (enumUniform NotRecommend SpecPriority))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Parents))), [(fmap show (enumUniform Usual GreatPret))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(HasNurs))), [(fmap show (enumUniform ProperNurs VeryCritNurs ))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Form))), [(fmap show (enumUniform CompleteFamilyForm FosterFamilyForm ))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Children))), [(fmap show (enumUniform OneChild MoreChilds ))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Housing))), [(fmap show (enumUniform ConvenientHousing CriticalHousing ))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Finance))), [(fmap show (enumUniform ConvenientFinance InconvFinance ))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Social))), [(fmap show (enumUniform NotProblematicSocial ProblematicSocial ))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Health))), [(fmap show (enumUniform NotRecommendHealth PriorityHealth ))])
-          ],
-      targetType = (Ref.SomeTypeRep (Ref.TypeRep @(Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass))),
-      maxDepth = 9,
-      weights =
-        ExpressionWeights
-          { lambdaSpucker = 0,
-            lambdaSchlucker = 10,
-            symbol = 100,
-            variable = 5,
-            constant = 5
-          }
-    }
-
-trainingFraction :: R
-trainingFraction = (2/3)
-
-lEE :: LamdaExecutionEnv
-lEE =
-  LamdaExecutionEnv
-    { -- For now these need to define all available functions and types. Generic functions can be used.
-      imports = ["LambdaDatasets.NurseryDefinition"],
-      training = True,
-      trainingData =
-        ( map fst (takeFraktion trainingFraction nurseryTrainingData),
-          map snd (takeFraktion trainingFraction nurseryTrainingData)
-        ),
-      testData =
-        ( map fst (dropFraktion trainingFraction nurseryTrainingData),
-          map snd (dropFraktion trainingFraction nurseryTrainingData)
-        ),
-      exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass))),
-      results = Map.empty
-    }
-
-shuffledLEE :: IO LamdaExecutionEnv
-shuffledLEE = do
-  mwc <- liftIO createSystemRandom
-  let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
-  itD <- smpl $ shuffle nurseryTrainingData
-  return
-    LamdaExecutionEnv
-      { -- For now these need to define all available functions and types. Generic functions can be used.
-        imports = ["LambdaDatasets.NurseryDefinition"],
-        training = True,
-        trainingData =
-          ( map fst (takeFraktion trainingFraction itD),
-            map snd (takeFraktion trainingFraction itD)
-          ),
-        testData =
-          ( map fst (dropFraktion trainingFraction itD),
-            map snd (dropFraktion trainingFraction itD)
-          ),
-        exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass))),
-        results = Map.empty
-      }
-
-data LamdaExecutionEnv = LamdaExecutionEnv
-  { -- For now these need to define all available functions and types. Generic functions can be used.
-    imports :: [Text],
-    training :: Bool,
-    trainingData :: ([(Parents, HasNurs, Form, Children, Housing, Finance, Social, Health)], [NurseryClass]),
-    testData :: ([(Parents, HasNurs, Form, Children, Housing, Finance, Social, Health)], [NurseryClass]),
-    exTargetType :: TypeRep,
-    -- todo: kindaHacky
-    results :: Map TypeRequester FittnesRes
-  }
-
-data FittnesRes = FittnesRes
-  { total :: R,
-    fitnessTotal :: R,
-    fitnessGeoMean :: R,
-    fitnessMean :: R,
-    accuracy :: R,
-    biasSize :: R,
-    totalSize :: N
-  }
-  deriving (Show)
-
-instance Fitness FittnesRes where
-  getR = total
-
-instance Evaluator TypeRequester LamdaExecutionEnv FittnesRes where
-  fitness' env tr = (results env) Map.! tr
-
-  calc env pop = do
-    let relevantResults = Map.filterWithKey (\k _ -> contains pop k) (results env)
-    let toAdd = NE.filter (\k -> not (Map.member k relevantResults)) pop
-    toInsert <- Hint.runInterpreter (evalResults env toAdd)
-    let insertPair (key, val) m = Map.insert key val m
-    let res = foldr insertPair relevantResults (fromRight (error ("To insert is " <> show toInsert)) toInsert)
-    return env {results = res}
-
-dset :: LamdaExecutionEnv -> ([(Parents, HasNurs, Form, Children, Housing, Finance, Social, Health)], [NurseryClass])
-dset lEE = if training lEE then trainingData lEE else testData lEE
-
-evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, FittnesRes)]
-evalResults ex trs = do
-  Hint.setImports $ (map T.unpack (imports ex)) ++ ["Protolude"]
-  Hint.unsafeSetGhcOption "-O2"
-  let arrayOfFunctionText = map toLambdaExpressionS trs
-  let textOfFunctionArray = "[" <> T.intercalate "," arrayOfFunctionText <> "]"
-  result <- Hint.interpret (T.unpack (textOfFunctionArray)) (Hint.as :: [Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass])
-  return $ zipWith (evalResult ex) trs result
-
-
-evalResult :: LamdaExecutionEnv -> TypeRequester -> (Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass) -> (TypeRequester, FittnesRes)
-evalResult ex tr result = ( tr,
-      FittnesRes
-        { total = acc * 100 + (biasSmall - 1),
-          fitnessTotal = fitness',
-          fitnessMean = meanOfAccuricyPerClass resAndTarget,
-          fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
-          accuracy = acc,
-          biasSize = biasSmall,
-          totalSize = countTrsR tr
-        }
-    )
-    where
-    res = map (\(a, b, c, d, e, f, g, h) -> result a b c d e f g h) (fst (dset ex))
-    resAndTarget = (zip (snd (dset ex)) res)
-    acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) / fromIntegral (length resAndTarget)
-    biasSmall = exp ((-(fromIntegral (countTrsR tr))) / 1000) -- 0 (schlecht) bis 1 (gut)
-    fitness' = meanOfAccuricyPerClass resAndTarget
-    score = fitness' + (biasSmall - 1)
-

lambda/src/Main.hs

@@ -1,76 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-import Options.Applicative
-import Pipes
-import Pretty
-import Protolude hiding (for)
-import System.IO
-import LambdaDatasets.IrisDataset
--- import LambdaDatasets.NurseryDataset
--- import LambdaDatasets.GermanDataset
-import Debug.Trace as DB
-import qualified Data.Map.Strict as Map
-
-data Options = Options
-  { iterations :: !N,
-    populationSize :: !N
-  }
-
-options :: Parser Options
-options =
-  Options
-    <$> option
-      auto
-      ( long "iterations"
-          <> short 'i'
-          <> metavar "N"
-          <> value 1500
-          <> help "Number of iterations"
-      )
-    <*> option
-      auto
-      ( long "population-size"
-          <> short 'p'
-          <> metavar "N"
-          <> value 100
-          <> help "Population size"
-      )
-
-optionsWithHelp :: ParserInfo Options
-optionsWithHelp =
-  info
-    (helper <*> options)
-    ( fullDesc
-        <> progDesc "Run a GA"
-        <> header "haga - Haskell implementations of EAs"
-    )
-
-main :: IO ()
-main =
-  execParser optionsWithHelp >>= \opts -> do
-    hSetBuffering stdout NoBuffering
-    lEE <- shuffledLEE
-    let cfg = GaRunConfig {
-      enviroment = lE,
-      initialEvaluator = lEE,
-      selectionType = Tournament 3,
-      termination = (steps (iterations opts)),
-      poulationSize = (populationSize opts),
-      stepSize = 90,
-      elitismRatio = 5/100
-    }
-    pop' <- runEffect (for (run cfg) logCsv)
-    lEE' <- calc lEE  pop'
-    let (res, _) = bests lEE' 5 pop'
-    let lEE' = lEE {training = False}
-    lEE' <- calc lEE' res
-    mapM_ (format lEE') res
-  where
-    format l s = do
-      let f = fitness' l s
-      putErrText $ show f <> "\n" <> pretty s
-    logCsv = putText . csv
-    csv (t, f) = show t <> " " <> show f

lib/Test.hs

@@ -1,21 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Main where
-
-import qualified GA
-import Protolude
-
-main :: IO ()
-main = do
-  _ <- GA.runTests
-  return ()
-
-if' :: Bool -> a -> a -> a
-if' True x _ = x
-if' False _ y = y

lib/Utils.hs

@@ -1,60 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Utils where
-
-import GA (R)
-import Protolude
-
-takeFraktion :: (RealFrac f) => f -> [a] -> [a]
-takeFraktion frac list = take (floor (frac * (fromIntegral (length list)))) list
-
-dropFraktion :: (RealFrac f) => f -> [a] -> [a]
-dropFraktion frac list = drop (floor (frac * (fromIntegral (length list)))) list
-
-meanOfAccuricyPerClass :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
-meanOfAccuricyPerClass results = mean $ map (accuracyInClass results) [minBound .. maxBound]
-
-geomeanOfAccuricyPerClass :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
-geomeanOfAccuricyPerClass results = geomean $ map (accuracyInClass results) [minBound .. maxBound]
-
-geomeanOfDistributionAccuracy :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
-geomeanOfDistributionAccuracy results = geomean $ map (distributionAccuracyForClass results) [minBound .. maxBound]
-
-distributionAccuracyForClass :: (Eq r) => [(r, r)] -> r -> R
-distributionAccuracyForClass results clas = (1 - (min 1 (fromIntegral (abs ((length (inResClass results clas)) - (length (inClass results clas)))) / fromIntegral (length (inClass results clas))))) * 100
-
-mean :: (Show f, RealFloat f) => [f] -> f
-mean values = (sum filteredValues) * (1 / (fromIntegral (length filteredValues)))
-  where
-    filteredValues = filter (not . isNaN) values
-
-geomean :: (Show f, RealFloat f) => [f] -> f
-geomean values = (product filteredValues) ** (1 / (fromIntegral (length filteredValues)))
-  where
-    filteredValues = filter (not . isNaN) values
-
-accuracyInClass :: (Eq r) => [(r, r)] -> r -> R
-accuracyInClass results clas = ((accuracy' (inResClass results clas)) * 100) / fromIntegral (length (inClass results clas))
-
-inClass :: (Eq r) => [(r, r)] -> r -> [(r, r)]
-inClass results clas = (filter ((clas ==) . fst) results)
-
-inResClass :: (Eq r) => [(r, r)] -> r -> [(r, r)]
-inResClass results clas = (filter ((clas ==) . snd) results)
-
-accuracy' :: (Eq r) => [(r, r)] -> R
-accuracy' results = fromIntegral $ length (filter (\(target, res) -> (res == target)) results)
-
-repeatedly :: (a -> Maybe a) -> a -> [a]
-repeatedly f x = case f x of
-  Nothing -> []
-  Just y -> y : repeatedly f y
-
-contains :: (Eq a, Foldable t) => t a -> a -> Bool
-contains list val = any (== val) list
-
-count :: (Eq a) => [a] -> a -> Int
-count [] _ = 0
-count ys find = length xs
-  where
-    xs = [xs | xs <- ys, xs == find]

run.sbatch

@@ -1,9 +0,0 @@
-#!/usr/bin/env bash
-#SBATCH --time=18:00:00
-#SBATCH --partition=cpu
-#SBATCH --array=0-30
-#SBATCH --output=./output/output_run_%j.txt
-#SBATCH --error=./output/error_run_%j.txt
-#SBATCH --nodelist=oc-compute02
-#SBATCH --mem=3G
-srun nix develop --command stack --no-nix --system-ghc --no-install-ghc run haga-lambda

src-students/Test.hs

@@ -1,21 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Main where
-
-import Protolude
-import qualified Seminar
-
-main :: IO ()
-main = do
-  _ <- Seminar.runTests
-  return ()
-
-if' :: Bool -> a -> a -> a
-if' True x _ = x
-if' False _ y = y

src/GA.hs

@@ -6,11 +6,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE GADTs #-}
+
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
 -- |
 -- Module      : GA
 -- Description : Abstract genetic algorithm
@@ -24,7 +20,7 @@
 -- In order to use it for a certain problem, basically, you have to make your
 -- solution type an instance of 'Individual' and then simply call the 'run'
 -- function.
-module GA (Environment (..), Fitness (..), Evaluator (..), Individual (..), GA.run, Tournament (..), N, R, Population, steps, bests, runTests, GaRunConfig (..)) where
+module GA (Environment, new, population, mutate, crossover1, crossover, nX, Fitness, getR, Evaluator, fitness,fitness', calc, Individual, GA.run, Tournament (..), N, R, Population, steps, bests, runTests) where
 
 import Control.Arrow hiding (first, second)
 import Data.List.NonEmpty ((<|))
@@ -35,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 ()
@@ -51,7 +46,7 @@ type R = Double
 -- |
 --  An Environment that Individuals of type i can be created from
 --  It stores all information required to create and change Individuals correctly
-class (Pretty e, Individual i) => Environment i e | e -> i, i -> e where
+class (Pretty e, Individual i) => Environment i e | e -> i where
   -- |
   --  Generates a completely random individual.
   new :: e -> RVar i
@@ -60,7 +55,7 @@ class (Pretty e, Individual i) => Environment i e | e -> i, i -> e 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
@@ -88,7 +83,7 @@ class (Pretty e, Individual i) => Environment i e | e -> i, i -> e where
 -- |
 --  An Evaluator that Individuals of type i can be evaluated by
 --  It stores all information required to evaluate an individuals fitness
-class (Individual i, Fitness r) => Evaluator i e r | e -> i r, i -> e where
+class (Individual i, Fitness r) => Evaluator i e r | i -> e r where
   -- |
   --  An individual's fitness. Higher values are considered “better”.
   --
@@ -97,15 +92,9 @@ class (Individual i, Fitness r) => Evaluator i e r | e -> i r, i -> e where
   fitness :: e -> i -> R
   fitness env i = getR ( fitness' env i)
 
-  -- |
-  --  An more complete fitness object, used to include more info to the output of the current fitness.
-  --  You can e.g. track individual size with this.
   fitness' :: e -> i -> r
 
-  -- |
+  -- TODO kinda hacky?!?
-  -- here, fitness values for the next generation can be calculated at once, and just once, using any monadic action, if necessary.
-  -- It is guaranteed that the e passed to fitness is the result of a calc function, where the individual was part of the Population passed.
-  -- It may be smart to reuse known results between invocations.
   calc :: e -> Population i -> IO e
   calc eval _ = do
     return eval
@@ -216,25 +205,21 @@ selectBest eval pElite pop nPop = do
         then return elitists
         else return $ elitists <> (fst $ bests eval (nPop - length elitists) (NE.fromList rest))
 
-
+run ::
--- This class encapsulates everything needed to run a generic genetic Algorithm
+  (Individual i, Evaluator i eval r, Environment i env, SelectionType s) =>
-data GaRunConfig i r eval env t where
+  eval ->
-  GaRunConfig :: (Individual i, Fitness r, Evaluator i eval r, Environment i env, SelectionType t) => {
+  env ->
-    enviroment :: env,
+  -- | Mechanism for selecting parents
-    initialEvaluator :: eval,
+  s ->
-    selectionType :: t,
+  -- | Number of parents @nParents@ for creating @nParents@ children
-    termination :: (Termination i),
+  N ->
-    poulationSize :: N,
+  -- | Elitism ratio @pElite@
-    stepSize :: N,
+  R ->
-    elitismRatio :: R
+  -- | Population size
-  } -> GaRunConfig i r eval env t
+  N ->
-
+  Termination i ->
-
+  Producer (Int, r) IO (Population i)
-run :: GaRunConfig i r eval env t -> Producer (Int, r) IO (Population i)
+run eval env selectionType nParents pElite nPop term = do
-run config@(GaRunConfig _ _ _ _ _ _ _) = do
-  let eval = initialEvaluator config
-  let env = enviroment config
-  let nPop = poulationSize config
   mwc <- liftIO createSystemRandom
   let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
   firstPop <- liftIO $ smpl $ (population env nPop)
@@ -242,17 +227,12 @@ run config@(GaRunConfig _ _ _ _ _ _ _) = do
   return res
   where
     runIter eval count pop smpl = (
-      if (termination config) pop count
+      if term pop count
         then do
           return pop
         else do
-          let env = enviroment config
-          let nPop = poulationSize config
-          let selecType = selectionType config
-          let nParents = stepSize config
-          let pElite = elitismRatio config
           eval <- liftIO $ calc eval pop
-          withKids <- liftIO $ smpl $ reproduce eval env selecType nParents pop
+          withKids <- liftIO $ smpl $ reproduce eval env selectionType nParents pop
           eval <- liftIO $ calc eval withKids
           resPop <- liftIO $ smpl $ selectBest eval pElite withKids nPop
           let fBest = fitness' eval $ NE.head $ fst $ bests eval 1 resPop
@@ -286,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
@@ -299,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/IrisDataset.hs

@@ -0,0 +1,149 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module IrisDataset
+  ( module LambdaCalculus,
+    module IrisDataset,
+    module IrisData,
+    module GA,
+  )
+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 qualified Type.Reflection as Ref
+
+irisLE :: LambdaEnviroment
+irisLE =
+  LambdaEnviroment
+    { functions =
+        Map.fromList
+          [ ((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'"]),
+            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
+            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> IrisClass -> IrisClass -> IrisClass))), ["if'"])
+          ],
+      constants =
+        Map.fromList
+          [ ((Ref.SomeTypeRep (Ref.TypeRep @(Float))), [(fmap show (uniform 0 10 :: RVar Float))]),
+            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool))), [(fmap show (uniform True False :: RVar Bool))]),
+            ((Ref.SomeTypeRep (Ref.TypeRep @(IrisClass))), [(fmap show (enumUniform Setosa Versicolor :: RVar IrisClass))])
+          ],
+      targetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
+      maxDepth = 10,
+      weights =
+        ExpressionWeights
+          { lambdaSpucker = 1,
+            lambdaSchlucker = 1,
+            symbol = 1,
+            variable = 2,
+            constant = 1
+          }
+    }
+
+irisLEE :: LamdaExecutionEnv
+irisLEE =
+  LamdaExecutionEnv
+    { -- For now these need to define all available functions and types. Generic functions can be used.
+      imports = ["IrisDataset"],
+      -- 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
+        ),
+      exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
+      -- todo: kindaHacky
+      results = Map.empty
+    }
+
+data LamdaExecutionEnv = LamdaExecutionEnv
+  { -- For now these need to define all available functions and types. Generic functions can be used.
+    imports :: [Text],
+    -- 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]),
+    exTargetType :: TypeRep,
+    -- todo: kindaHacky
+    results :: Map TypeRequester FittnesRes
+  }
+
+data FittnesRes = FittnesRes
+  { total :: R,
+    fitnessTotal :: R,
+    fitnessGeoMean :: R,
+    fitnessMean :: R,
+    accuracy :: Int,
+    biasDist :: R,
+    biasSize :: R
+  }
+  deriving (Show)
+
+instance Fitness FittnesRes where
+  getR = total
+
+instance Evaluator TypeRequester LamdaExecutionEnv FittnesRes where
+  fitness' env tr = (results env) Map.! tr
+
+  calc env pop = do
+    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 undefined toInsert)
+    return env {results = res}
+
+
+evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, FittnesRes)]
+evalResults ex trs = mapM (evalResult ex) trs
+
+evalResult :: LamdaExecutionEnv -> TypeRequester -> Hint.InterpreterT IO (TypeRequester, FittnesRes)
+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 (trainingData ex))
+  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 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
+    ( tr,
+      FittnesRes
+        { total = score,
+          fitnessTotal = fitness',
+          fitnessMean = meanOfAccuricyPerClass resAndTarget,
+          fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
+          accuracy = acc,
+          biasDist = biasWellDistributed,
+          biasSize = biasSmall
+        }
+    )
+
+if' :: Bool -> a -> a -> a
+if' True e _ = e
+if' False _ e = e
+

src/LambdaCalculus.hs

@@ -9,7 +9,7 @@
 
 module LambdaCalculus where
 
-import Data.List (foldr1, intersect, last, nub, (!!), (\\))
+import Data.List (foldr1, last)
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import Data.Maybe
@@ -17,15 +17,12 @@ import Data.Random
 import qualified Data.Text as T
 import Data.Tuple.Extra
 import Data.Typeable
-import Debug.Trace as DB
 import GA
 import Pretty
 import Protolude
-import Protolude.Error
 import Test.QuickCheck hiding (sample, shuffle)
 import Test.QuickCheck.Monadic (assert, monadicIO)
 import qualified Type.Reflection as Ref
-import Utils
 
 data ExpressionWeights = ExpressionWeights
   { lambdaSpucker :: Int,
@@ -74,6 +71,7 @@ exampleLE =
 
 type BoundVars = [TypeRep]
 
+
 -- we need a dynamic typ with a concept of equality here, should we want to interpret the result, instead of compiling it...
 type ConVal = Text
 
@@ -94,7 +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
@@ -178,7 +176,7 @@ genLambdaSchlucker env@(LambdaEnviroment functions constants _ _ weights) depthL
   let args = typeRepArgs target
   let lambaType = fromJust (head args)
   let toFind = last args
-  typeRequester <- genTypeRequester env (depthLeft + 1) toFind (boundVar ++ [lambaType])
+  typeRequester <- genTypeRequester env depthLeft toFind (boundVar ++ [lambaType])
   return (LambdaSchlucker typeRequester (boundVar ++ [lambaType]))
 
 genLambdaConst :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
@@ -233,148 +231,62 @@ instance Environment TypeRequester LambdaEnviroment where
     return tr
 
   mutate env@(LambdaEnviroment _ _ _ maxDepth _) tr = do
-    selfCrossover <- uniform True False
+    let trCount = countTrsR (tr)
-    co <- crossover1 env tr tr
+    selectedTR <- uniform 1 trCount
-    if selfCrossover && isJust co
+    let (depthAt, (TR trep _ bound)) = depthLeftAndTypeAtR tr selectedTR maxDepth
-      then do
+    res <- genTypeRequester env depthAt trep bound
-        let (tr1, tr2) = fromJust co
+    return $ replaceAtR selectedTR tr res
-        return $ minimumBy (compare `on` countTrsR) [tr1, tr2]
-      else do
-        let trCount = countTrsR (tr)
-        selectedTR <- uniform 1 trCount
-        let (depthAt, (TR trep _ bound)) = depthLeftAndTypeAtR tr selectedTR maxDepth
-        res <- genTypeRequester env depthAt trep bound
-        return $ replaceAtR selectedTR tr res
 
   nX _ = 3 -- todo!
 
   crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do
-    let trCount = countTrsR tr1
+    return Nothing
-    selectedIndex1 <- uniform 1 trCount
+
-    let (depthAt1, selectedTr1@(TR _ _ bound1)) = depthLeftAndTypeAtR tr1 selectedIndex1 maxDepth
+-- TODO: crossover!
-    let depthLeftNeeded = depthOfTR selectedTr1
+--  let trCount = countTrsR tr1
-    let indexes = findIndicesWhere tr2 (isCompatibleTr selectedTr1 (maxDepth - depthAt1) depthLeftNeeded) 0 0
+--  selectedIndex1 <- uniform 1 trCount
-    if length indexes == 0
+--  let (depthAt, selectedTr1@(TR trep _ bound)) = depthLeftAndTypeAtR tr selectedTR maxDepth
-      then return Nothing
+--  let indexes = findIndicesWhere tr2 ( == trep)
-      else
+--  if length indexes == 0 then return Nothing else (do
-        ( do
+--    (selectedTr2,selectedIndex2) <- randomElement indexes)
-            (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)
-        )
 
 -- helper
-depthOfTR :: TypeRequester -> Int
-depthOfTR (TR _ (Just le@(LambdaSchlucker _ _)) _) = maximum (0:(map depthOfTR (asList le)))
-depthOfTR (TR _ (Just le) _) = maximum (0:(map depthOfTR (asList le))) + 1
-depthOfTR _ = error "le Not Just (depthOfTR)"
 
-adaptBoundVars :: TypeRequester -> BoundVars -> RVar TypeRequester
+-- findIndicesWhere:: TypeRequester -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)]
-adaptBoundVars tr@(TR _ _ bvOld) bvNew = do
+-- findIndicesWhere tr@(TR t lE _) filte indx = case lE of
-  newIndexMap <- generateConversionIndexMap bvOld bvNew
+--                            Just le -> (tr, indx+1):(findIndicesWhere' (asList le) filte (indx+1))
-  return $ convertTr tr bvOld bvNew newIndexMap
+--                            Nothing -> undefined
 
-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:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr))
-convertTr _ _ _ _ = error "le Not Just (convertTr)"
-
--- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show)
-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 -> Int -> Int -> TypeRequester -> Int -> Bool
-isCompatibleTr tr1@(TR trep1 _ bound1) maxDepthOfTR2 maxDepthOfNode tr2@(TR trep2 _ bound2) depthOfNode
-  | trep1 == trep2 = allUsedBound (usedVars bound1 tr1) bound2 && allUsedBound (usedVars bound2 tr2) bound1 && maxDepthOfTR2 >= (depthOfTR tr2) && maxDepthOfNode >= depthOfNode
-  | 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 -> Int -> Bool) -> Int -> Int -> [(TypeRequester, Int)]
-findIndicesWhere tr@(TR _ (Just le@(LambdaSchlucker _ _)) _) filte indx currDepth = if filte tr currDepth then (tr, indx + 1) : (findIndicesWhere' (asList le) filte (indx + 1) (currDepth)) else (findIndicesWhere' (asList le) filte (indx + 1) (currDepth))
-findIndicesWhere tr@(TR _ lE _) filte indx currDepth = case lE of
-  Just le -> if filte tr currDepth then (tr, indx + 1) : (findIndicesWhere' (asList le) filte (indx + 1) (currDepth + 1)) else (findIndicesWhere' (asList le) filte (indx + 1) (currDepth + 1))
-  Nothing -> error "Nothing in findIndicesWhere"
-
-findIndicesWhere' :: [TypeRequester] -> (TypeRequester -> Int -> Bool) -> Int -> Int -> [(TypeRequester, Int)]
-findIndicesWhere' [] _ _ _ = []
-findIndicesWhere' [tr] f indx currDepth = (findIndicesWhere tr f indx currDepth)
-findIndicesWhere' (tr : trs) f indx currDepth = (findIndicesWhere tr f indx currDepth) ++ (findIndicesWhere' trs f (indx + countTrsR tr) currDepth)
 
 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@(LambdaSchlucker tr bv) indexLeft depthLeft = depthLeftAndTypeInSubtreeWithIndex (asList le) indexLeft (depthLeft + 1)
 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
@@ -384,6 +296,17 @@ countTrsR tr@(TR t lE _) = case lE of
 countTrs :: LambdaExpression -> Int
 countTrs le = sum (map countTrsR (asList le))
 
+repeatedly :: (a -> Maybe a) -> a -> [a]
+repeatedly f x = case f x of
+  Nothing -> []
+  Just y -> y : repeatedly f y
+
+count :: (Eq a) => [a] -> a -> Int
+count [] find = 0
+count ys find = length xs
+  where
+    xs = [xs | xs <- ys, xs == find]
+
 -- Test Stuff
 
 testConstInt :: TypeRequester
@@ -543,3 +466,34 @@ eToLambdaExpressionShort (Constan (valS)) = valS
 
 res :: Int -> ResClass
 res = ((\lInt0 -> ((iteClass ((eqInt ((lInt0) :: (Int)) ((1) :: (Int))) :: (Bool)) ((Class1) :: (ResClass)) ((iteClass ((eqInt ((lInt0) :: (Int)) ((2) :: (Int))) :: (Bool)) ((Class2) :: (ResClass)) ((iteClass ((eqInt ((lInt0) :: (Int)) ((3) :: (Int))) :: (Bool)) ((Class3) :: (ResClass)) ((Class3) :: (ResClass))) :: (ResClass))) :: (ResClass))) :: (ResClass))) :: (Int -> ResClass))
+
+
+meanOfAccuricyPerClass :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
+meanOfAccuricyPerClass results = mean $ map (accuracyInClass results) [minBound .. maxBound]
+
+geomeanOfAccuricyPerClass :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
+geomeanOfAccuricyPerClass results = geomean $ map (accuracyInClass results) [minBound .. maxBound]
+
+geomeanOfDistributionAccuracy :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
+geomeanOfDistributionAccuracy results = geomean $ map (distributionAccuracyForClass results) [minBound .. maxBound]
+
+distributionAccuracyForClass :: (Eq r) => [(r, r)] -> r -> R
+distributionAccuracyForClass results clas = (1 - (min 1 (fromIntegral (abs ((length (inResClass results clas)) - (length (inClass results clas)))) / fromIntegral (length (inClass results clas))))) * 100
+
+mean :: (Show f, Floating f) => [f] -> f
+mean values = (sum values) * (1 / (fromIntegral (length values)))
+
+geomean :: (Show f, Floating f) => [f] -> f
+geomean values = (product values) ** (1 / (fromIntegral (length values)))
+
+accuracyInClass :: (Eq r) => [(r, r)] -> r -> R
+accuracyInClass results clas = ((accuracy'(inResClass results clas)) * 100) / fromIntegral (length (inClass results clas))
+
+inClass :: (Eq r) => [(r, r)] -> r -> [(r, r)]
+inClass results clas = (filter ((clas ==) . fst) results)
+
+inResClass :: (Eq r) => [(r, r)] -> r -> [(r, r)]
+inResClass results clas = (filter ((clas ==) . snd) results)
+
+accuracy' :: (Eq r) => [(r, r)] -> R
+accuracy' results = fromIntegral $ length (filter (\(target, res) -> (res == target)) results)

src/Main.hs

@@ -7,8 +7,9 @@ import Pipes
 import Pretty
 import Protolude hiding (for)
 import System.IO
-import Seminar
+-- import Szenario212Pun
-import Szenario191
+-- import Szenario191
+import IrisDataset
 
 data Options = Options
   { iterations :: !N,
@@ -23,7 +24,7 @@ options =
       ( long "iterations"
           <> short 'i'
           <> metavar "N"
-          <> value 1500
+          <> value 1000
           <> help "Number of iterations"
       )
     <*> option
@@ -31,7 +32,7 @@ options =
       ( long "population-size"
           <> short 'p'
           <> metavar "N"
-          <> value 400
+          <> value 50
           <> help "Population size"
       )
 
@@ -48,23 +49,18 @@ main :: IO ()
 main =
   execParser optionsWithHelp >>= \opts -> do
     hSetBuffering stdout NoBuffering
-    let cfg = GaRunConfig {
+    let env = irisLE
-      enviroment = AssignmentEnviroment (students prios, topics prios),
+    let selType = Tournament 3
-      initialEvaluator = prios,
+    let run' = run irisLEE env selType 40 (5 / 100) (populationSize opts) (steps (iterations opts))
-      selectionType = Tournament 3,
+    pop' <-
-      termination = (steps (iterations opts)),
+      runEffect (for run' logCsv)
-      poulationSize = (populationSize opts),
+
-      stepSize = 120,
+    irisLE <- calc irisLEE  pop'
-      elitismRatio = 5/100
+    let (res, _) = bests irisLE 5 pop'
-    }
+    mapM_ (format irisLE) res
-    pop' <- runEffect (for (run cfg) logCsv)
-    prios' <- calc prios  pop'
-    let (res, _) = bests prios' 5 pop'
-    prios' <- calc prios' res
-    mapM_ (format prios') res
   where
-    format seminarL s = do
+    format irisL s = do
-      let f = fitness' seminarL s
+      let f = fitness' irisL s
       putErrText $ show f <> "\n" <> pretty s
     logCsv = putText . csv
     csv (t, f) = show t <> " " <> show f

src/Seminar.hs

@@ -127,6 +127,8 @@ instance Environment Assignment AssignmentEnviroment where
   --  Borrowed from TSP: Crossover cuts the parents in two and swaps them (if this
   --  does not create an invalid offspring).
   --
+  --  TODO Assumes that both individuals are based on the same priorities.
+  --
   crossover1 e assignment1 assignment2 = do
     let l = fromIntegral $ min (length assignment1) (length assignment2) :: Double
     x <- uniform 0 l

src/Test.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Main where
+
+import Data.Random
+import Data.Typeable
+import qualified GA
+import qualified LambdaCalculus
+import Protolude
+import qualified Seminar
+import System.Random.MWC (createSystemRandom)
+import qualified Type.Reflection as Ref
+
+main :: IO ()
+main = do
+  -- _ <- GA.runTests
+  -- _ <- Seminar.runTests
+  -- _ <- putStrLn $ ((show (typeRepArgs (Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int -> Text))))) :: Text)
+  -- _ <- putStrLn $ ((show (typeRepArgs (Ref.SomeTypeRep (Ref.TypeRep @(Text))))) :: Text)
+  mwc <- createSystemRandom
+  r <- sampleFrom mwc $ GA.new LambdaCalculus.exampleLE
+  _ <- putStrLn $ LambdaCalculus.toLambdaExpressionS $ r
+  r <- sampleFrom mwc $ GA.new LambdaCalculus.exampleLE
+  _ <- putStrLn $ LambdaCalculus.toLambdaExpressionS $ r
+  -- _ <- putStrLn (LambdaCalculus.toLambdaExpressionShort LambdaCalculus.testIntToClassCorrect)
+  -- _ <- putStrLn $ ((show (LambdaCalculus.res 1)) :: Text)
+  -- _ <- putStrLn $ ((show (LambdaCalculus.res 2)) :: Text)
+  -- _ <- putStrLn $ ((show (LambdaCalculus.res 3)) :: Text)
+  return ()
+
+if' :: Bool -> a -> a -> a
+if' True x _ = x
+if' False _ y = y