fix fittness

.gitignore

@@ -1,2 +1,5 @@
 /.ghc.environment.x86_64-linux-8.6.5
 dist-newstyle/
+.stack-work
+haga.prof
+**.kate-swp

build.sbatch

@@ -0,0 +1,9 @@
+#!/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": 1655624069,
+        "lastModified": 1713145326,
-        "narHash": "sha256-7g1zwTdp35GMTERnSzZMWJ7PG3QdDE8VOX3WsnOkAtM=",
+        "narHash": "sha256-m7+IWM6mkWOg22EC5kRUFCycXsXLSU7hWmHdmBfmC3s=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "0d68d7c857fe301d49cdcd56130e0beea4ecd5aa",
+        "rev": "53a2c32bc66f5ae41a28d7a9a49d321172af621e",
         "type": "github"
       },
       "original": {
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "0d68d7c857fe301d49cdcd56130e0beea4ecd5aa",
+        "rev": "53a2c32bc66f5ae41a28d7a9a49d321172af621e",
         "type": "github"
       }
     },

flake.nix

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

haga.cabal

@@ -1,4 +1,4 @@
-cabal-version:       2.2
+cabal-version:       3.4
 name:                haga
 version:             0.1.0.0
 synopsis:            Simplistic genetic algorithms library
@@ -20,82 +20,119 @@ category:            Optimization
 build-type:          Simple
 
 library
-  build-depends:       base ^>=4.14.0.0
+  build-depends:       base
+                     , bytestring
                      , cassava
+                     , containers
                      , extra
-                     , MonadRandom
+                     , hint
                      , monad-loops
+                     , MonadRandom
+                     , mwc-random
                      , optparse-applicative
+                     , parallel
+                     , path
                      , pipes
+                     , primitive
                      , protolude
                      , QuickCheck
                      , quickcheck-instances
                      , random
-                     -- 0.3.0.0 introduces at least one truly breaking change.
+                     , random-fu
-                     , random-fu <0.3.0.0
                      , random-shuffle
                      , text
                      , wl-pprint-text
   default-language:    Haskell2010
-  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans
+  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans -O2
-  hs-source-dirs:      src
+  hs-source-dirs:      lib, lambda/lib
+  other-modules:       CommonDefinition
   exposed-modules:     GA
-                     , Seminar
+                     , LambdaCalculus
                      , Pretty
-                     , Szenario191
+                     , Utils
-                     , Szenario202
+                     , LambdaDatasets.NurseryDefinition
-                     , Analysis
+                     , LambdaDatasets.GermanDefinition
+                     , LambdaDatasets.IrisDefinition
 
-executable haga
+executable haga-lambda
-  build-depends:       base ^>=4.14.0.0
+  build-depends:       base
+                     , bytestring
                      , cassava
+                     , containers
                      , extra
-                     , MonadRandom
+                     , hint
+                     , haga
                      , monad-loops
+                     , MonadRandom
+                     , mwc-random
                      , optparse-applicative
+                     , parallel
+                     , path
                      , pipes
+                     , primitive
                      , protolude
                      , QuickCheck
                      , quickcheck-instances
                      , random
-                     -- 0.3.0.0 introduces at least one truly breaking change.
+                     , random-fu
-                     , random-fu <0.3.0.0
                      , random-shuffle
                      , text
                      , wl-pprint-text
   default-language:    Haskell2010
-  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans
+  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
-  hs-source-dirs:      src
+  hs-source-dirs:      lambda/src
   main-is:             Main.hs
-  other-modules:       GA
+  other-modules:       LambdaDatasets.NurseryDataset
-                     , Seminar
+                     , LambdaDatasets.NurseryData
-                     , Pretty
+                     , LambdaDatasets.GermanDataset
+                     , 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
-                     , Szenario202
 
 executable haga-test
-  build-depends:       base ^>=4.14.0.0
+  build-depends:       base
-                     , cassava
+                     , bytestring
                      , Cabal
+                     , cassava
+                     , containers
                      , extra
-                     , MonadRandom
+                     , haga
+                     , hint
                      , monad-loops
+                     , MonadRandom
+                     , mwc-random
                      , optparse-applicative
+                     , parallel
+                     , path
                      , pipes
+                     , primitive
                      , protolude
                      , QuickCheck
                      , quickcheck-instances
                      , random
-                     -- 0.3.0.0 introduces at least one truly breaking change.
+                     , random-fu
-                     , random-fu <0.3.0.0
                      , random-shuffle
                      , text
                      , wl-pprint-text
   default-language:    Haskell2010
-  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans
+  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
-  hs-source-dirs:      src
+  hs-source-dirs:      lib
   main-is:             Test.hs
-  other-modules:       GA
-                     , Seminar
-                     , Pretty
-                     , Szenario191

lambda/README.md

@@ -0,0 +1,17 @@
+# 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

@@ -0,0 +1,9 @@
+{-# 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

@@ -0,0 +1,38 @@
+{-# 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

@@ -0,0 +1,16 @@
+{-# 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

@@ -0,0 +1,32 @@
+{-# 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

@@ -0,0 +1,208 @@
+{-# 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 = 5,
+      weights =
+        ExpressionWeights
+          { lambdaSpucker = 10,
+            lambdaSchlucker = 1,
+            symbol = 20,
+            variable = 100,
+            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

@@ -0,0 +1,168 @@
+{-# 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

@@ -0,0 +1,173 @@
+{-# 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 = 5,
+      weights =
+        ExpressionWeights
+          { lambdaSpucker = 10,
+            lambdaSchlucker = 1,
+            symbol = 20,
+            variable = 100,
+            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

@@ -0,0 +1,199 @@
+{-# 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 = 5,
+      weights =
+        ExpressionWeights
+          { lambdaSpucker = 10,
+            lambdaSchlucker = 1,
+            symbol = 20,
+            variable = 100,
+            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

@@ -0,0 +1,76 @@
+{-# 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/GA.hs

@@ -0,0 +1,432 @@
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+-- |
+-- Module      : GA
+-- Description : Abstract genetic algorithm
+-- Copyright   : David Pätzel, 2019
+-- License     : GPL-3
+-- Maintainer  : David Pätzel <david.paetzel@posteo.de>
+-- Stability   : experimental
+--
+-- Simplistic abstract definition of a genetic algorithm.
+--
+-- 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
+
+import Control.Arrow hiding (first, second)
+import Data.List.NonEmpty ((<|))
+import qualified Data.List.NonEmpty as NE
+import qualified Data.List.NonEmpty.Extra as NE (appendl)
+import qualified Data.Map.Strict as Map
+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 ()
+import Test.QuickCheck.Monadic
+
+-- TODO there should be a few 'shuffle's here
+
+-- TODO enforce this being > 0
+type N = Int
+
+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
+  -- |
+  --  Generates a completely random individual.
+  new :: e -> RVar i
+
+  -- |
+  --  Generates a random population of the given size.
+  population :: e -> N -> RVar (Population i)
+  population env n
+    | n <= 0 = error "nonPositive in population"
+    | otherwise = NE.fromList <$> replicateM n (new env)
+
+  mutate :: e -> i -> RVar i
+
+  crossover1 :: e -> i -> i -> RVar (Maybe (i, i))
+
+  nX :: e -> N
+
+  -- |
+  --  Performs an n-point crossover.
+  --
+  --  Given the function for single-point crossover, 'crossover1', this function can
+  --  be derived through recursion and a monad combinator (which is also the default
+  --  implementation).
+  crossover :: e -> i -> i -> RVar (Maybe (i, i))
+  crossover e = crossover' e (nX e)
+
+  crossover' :: e -> N -> i -> i -> RVar (Maybe (i, i))
+  crossover' env n i1 i2
+    | n <= 0 = return $ Just (i1, i2)
+    | otherwise = do
+        isM <- crossover1 env i1 i2
+        maybe (return Nothing) (uncurry (crossover' env (n - 1))) isM
+
+-- |
+--  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
+  -- |
+  --  An individual's fitness. Higher values are considered “better”.
+  --
+  --  We explicitely allow fitness values to be have any sign (see, for example,
+  --  'proportionate1').
+  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
+
+  -- |
+  -- 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
+
+class (Pretty i, Ord i) => Individual i
+
+class (Show i) => Fitness i where
+  getR :: i -> R
+
+instance Fitness Double where
+  getR d = d
+
+-- |
+-- Populations are just basic non-empty lists.
+type Population i = NonEmpty i
+
+-- |
+-- Produces offspring circularly from the given list of parents.
+children ::
+  (Individual i, Environment i e) =>
+  e ->
+  NonEmpty i ->
+  RVar (NonEmpty i)
+children e (i :| []) = (:| []) <$> mutate e i
+children e (i1 :| [i2]) = children2 e i1 i2
+children e (i1 :| i2 : is') =
+  (<>) <$> children2 e i1 i2 <*> children e (NE.fromList is')
+
+children2 :: (Individual i, Environment i e) => e -> i -> i -> RVar (NonEmpty i)
+children2 e i1 i2 = do
+  -- TODO Add crossover probability?
+  (i3, i4) <- fromMaybe (i1, i2) <$> crossover e i1 i2
+  i5 <- mutate e i3
+  i6 <- mutate e i4
+  return $ i5 :| [i6]
+
+-- |
+-- The best according to a function; returns up to @k@ results and the remaining
+-- population.
+--
+-- If @k <= 0@, this returns the best one anyway (as if @k == 1@).
+bestsBy ::
+  (Individual i) =>
+  N ->
+  (i -> R) ->
+  Population i ->
+  (NonEmpty i, [i])
+bestsBy k f pop
+  | k <= 0 = bestsBy 1 f pop
+  | otherwise =
+      let (elites, rest) = NE.splitAt k $ map fst $ NE.sortBy (comparing (Down . snd)) $ map (\i -> (i, f i)) pop
+       in (NE.fromList elites, rest)
+
+-- |
+-- The @k@ best individuals in the population when comparing using the supplied
+-- function.
+bestsBy' :: (Individual i) => N -> (i -> R) -> Population i -> [i]
+bestsBy' k f pop
+  | k <= 0 = bestsBy' 1 f pop
+  | otherwise = NE.take k $ map fst $ NE.sortBy (comparing (Down . snd)) $ map (\i -> (i, f i)) pop
+
+-- |
+-- The @k@ worst individuals in the population (and the rest of the population).
+worst :: (Individual i, Evaluator i e r) => e -> N -> Population i -> (NonEmpty i, [i])
+worst e k = bestsBy k (negate . fitness e)
+
+-- |
+-- The @k@ best individuals in the population (and the rest of the population).
+bests :: (Individual i, Evaluator i e r) => e -> N -> Population i -> (NonEmpty i, [i])
+bests e k = bestsBy k (fitness e)
+
+-- TODO add top x percent parent selection (select n guys, sort by fitness first)
+
+reproduce ::
+  (Individual i, Environment i env, Evaluator i eval r, SelectionType s) =>
+  eval ->
+  env ->
+  -- | Mechanism for selecting parents
+  s ->
+  -- | Number of parents @nParents@ for creating @nParents@ children
+  N ->
+  Population i ->
+  RVar (Population i)
+reproduce eval env selectT nParents pop = do
+  iParents <-select selectT nParents pop eval
+  iChildren <- NE.filter (`notElem` pop) <$> children env iParents
+  let pop' = pop `NE.appendl` iChildren
+  return pop'
+
+selectBest ::
+  (Individual i, Evaluator i eval r) =>
+  eval ->
+  -- | Elitism ratio @pElite@
+  R ->
+  Population i ->
+  -- | How many individuals should be selected
+  N ->
+  RVar (Population i)
+selectBest eval pElite pop nPop = do
+  let eliteSize = floor . (pElite *) . fromIntegral $ nPop
+  let (elitists, rest) = bests eval eliteSize pop
+  case rest of
+    [] -> return elitists
+    _notEmpty ->
+      -- NOTE 'bests' always returns at least one individual, thus we need this
+      -- slightly ugly branching
+      if length elitists == nPop
+        then return elitists
+        else return $ elitists <> (fst $ bests eval (nPop - length elitists) (NE.fromList rest))
+
+
+-- This class encapsulates everything needed to run a generic genetic Algorithm
+data GaRunConfig i r eval env t where
+  GaRunConfig :: (Individual i, Fitness r, Evaluator i eval r, Environment i env, SelectionType t) => {
+    enviroment :: env,
+    initialEvaluator :: eval,
+    selectionType :: t,
+    termination :: (Termination i),
+    poulationSize :: N,
+    stepSize :: N,
+    elitismRatio :: R
+  } -> GaRunConfig i r eval env t
+
+
+run :: GaRunConfig i r eval env t -> Producer (Int, r) IO (Population i)
+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)
+  res <- runIter eval 0 firstPop smpl
+  return res
+  where
+    runIter eval count pop smpl = (
+      if (termination config) 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
+          eval <- liftIO $ calc eval withKids
+          resPop <- liftIO $ smpl $ selectBest eval pElite withKids nPop
+          let fBest = fitness' eval $ NE.head $ fst $ bests eval 1 resPop
+          Pipes.yield (count, fBest)
+          res <- runIter eval (count + 1) resPop smpl
+          return res)
+
+-- * Selection mechanisms
+
+-- |
+-- A function generating a monadic action which selects a given number of
+-- individuals from the given population.
+data Tournament = Tournament N
+
+class SelectionType t where
+  select :: (Individual i, Evaluator i e r) => t -> N -> Population i -> e -> RVar (NonEmpty i)
+
+-- type Selection m i = N -> Population i -> m (NonEmpty i)
+
+instance SelectionType Tournament where
+  select (Tournament i) count pop eval = fmap NE.fromList (replicateM count (tournament1 eval i pop))
+
+-- |
+-- Selects one individual from the population using tournament selection.
+tournament1 ::
+  (Individual i, Evaluator i e r) =>
+  e ->
+  -- | Tournament size
+  N ->
+  Population i ->
+  RVar i
+tournament1 eval nTrnmnt pop
+  -- TODO Use Positive for this constraint
+  | nTrnmnt <= 0 = error "nonPositive in tournament1"
+  | otherwise = do
+      paricipants <- withoutReplacement nTrnmnt pop
+      return $ NE.head $ fst $ bests eval 1 paricipants
+
+-- |
+-- Selects @n@ individuals uniformly at random from the population (without
+-- replacement, so if @n >= length pop@, simply returns @pop@).
+withoutReplacement ::
+  -- | How many individuals to select
+  N ->
+  Population i ->
+  RVar (NonEmpty i)
+withoutReplacement 0 _ = error "0 in withoutReplacement"
+withoutReplacement n pop
+  | n >= length pop = return pop
+  | otherwise = fmap (NE.fromList) (shuffleNofM n (length pop) (NE.toList pop))
+
+-- * Termination criteria
+
+-- |
+-- Termination decisions may take into account the current population and the
+-- current iteration number.
+type Termination i = Population i -> N -> Bool
+
+-- |
+-- Termination after a number of steps.
+steps :: N -> Termination i
+steps tEnd _ t = t >= tEnd
+
+-- * Helper functions
+
+-- |
+-- Shuffles a non-empty list.
+shuffle' :: NonEmpty a -> RVar (NonEmpty a)
+shuffle' xs@(_ :| []) = return xs
+shuffle' xs = fmap (NE.fromList) (shuffle (toList xs))
+
+instance Pretty Integer where
+  pretty i = "Found int: " <> show i
+
+instance Individual Integer
+
+newtype IntTestEnviroment = IntTestEnviroment ((Integer, Integer), Integer, N) deriving (Eq) -- IntTestEnviroment ((0,100000),10)
+
+instance Pretty IntTestEnviroment where
+  -- instance Pretty (Maybe Student) where
+  pretty (IntTestEnviroment ((i, j), k, _)) = "IntTestEnviroment of Individuals between " <> (show i) <> " and " <> (show j) <> " variance when mutating is " <> (show k)
+
+instance Environment Integer IntTestEnviroment where
+  new (IntTestEnviroment ((from, to), _, _)) = uniform from to
+
+  nX (IntTestEnviroment ((_, _), _, n)) = n
+
+  mutate (IntTestEnviroment ((from, to), wiggle, _)) i = uniform (max from (i - wiggle)) (min to (i + wiggle))
+
+  crossover1 _ i1 i2 = do
+    i1' <- uniform i1 i2
+    i2' <- uniform i1 i2
+    return $ Just (i1', i2')
+
+data NoData = NoData deriving (Eq)
+
+instance Evaluator Integer NoData Double where
+  fitness _ = fromIntegral . negate
+
+prop_children_asManyAsParents ::
+  N -> NonEmpty Integer -> Property
+prop_children_asManyAsParents nX is =
+  again $
+    monadicIO $
+      do
+        let e = IntTestEnviroment ((0, 100000), 10, nX)
+        mwc <- Test.QuickCheck.Monadic.run create
+        is' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (children e is)
+        return $ counterexample (show is') $ length is' == length is
+
+prop_bestsBy_isBestsBy' :: Int -> Population Integer -> Property
+prop_bestsBy_isBestsBy' k pop =
+  k > 0 ==>
+    monadicIO $
+      do
+        let a = fst $ bestsBy k (fitness NoData) pop
+        let b = bestsBy' k (fitness NoData) pop
+        assert $ NE.toList a == b
+
+prop_bestsBy_lengths :: Int -> Population Integer -> Property
+prop_bestsBy_lengths k pop =
+  k > 0 ==> monadicIO $ do
+    let (bests, rest) = bestsBy k (fitness NoData) pop
+    assert $
+      length bests == min k (length pop) && length bests + length rest == length pop
+
+-- TODO: re-add!
+-- prop_stepSteady_constantPopSize ::
+--  NonEmpty Integer -> Property
+-- prop_stepSteady_constantPopSize pop =
+--  forAll
+--    ( (,)
+--        <$> choose (1, length pop)
+--        <*> choose (1, length pop)
+--    )
+--    $ \(nParents, nX) -> monadicIO $ do
+--      let pElite = 0.1
+--      let eval = NoData
+--      let env = IntTestEnviroment ((0, 100000), 10, nX)
+--      mwc <- Test.QuickCheck.Monadic.run create
+--      pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (stepSteady eval env (tournament eval 4) nParents nX pElite pop)
+--      return . counterexample (show pop') $ length pop' == length pop
+
+prop_tournament_selectsN :: Int -> Int -> NonEmpty Integer -> Property
+prop_tournament_selectsN nTrnmnt n pop =
+  0 < nTrnmnt
+    && nTrnmnt < length pop
+    && 0 < n
+    ==> monadicIO
+    $ do
+      mwc <- Test.QuickCheck.Monadic.run create
+      pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (select (Tournament 2) n pop NoData)
+      assert $ length pop' == n
+
+prop_withoutReplacement_selectsN :: Int -> NonEmpty a -> Property
+prop_withoutReplacement_selectsN n pop =
+  0 < n && n <= length pop ==>
+    monadicIO
+      ( do
+          mwc <- Test.QuickCheck.Monadic.run create
+          pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (withoutReplacement n pop)
+          assert $ length pop' == n
+      )
+
+prop_shuffle_length :: NonEmpty a -> Property
+prop_shuffle_length xs =
+  monadicIO
+    ( do
+        mwc <- Test.QuickCheck.Monadic.run create
+        xs' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (shuffle' xs)
+        assert $ length xs' == length xs
+    )
+
+runTests :: IO Bool
+runTests = $quickCheckAll
+
+return []

lib/LambdaCalculus.hs

@@ -0,0 +1,545 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module LambdaCalculus where
+
+import Data.List (foldr1, intersect, last, nub, (!!), (\\))
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map.Strict as Map
+import Data.Maybe
+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,
+    lambdaSchlucker :: Int,
+    symbol :: Int,
+    variable :: Int,
+    constant :: Int
+  }
+
+data LambdaEnviroment = LambdaEnviroment
+  { functions :: (Map TypeRep [ConVal]),
+    constants :: (Map TypeRep [RVar ConVal]),
+    targetType :: TypeRep,
+    maxDepth :: Int,
+    weights :: ExpressionWeights
+  }
+
+showSanifid :: (Show a) => a -> Text
+showSanifid var = T.replace " -> " "To" (show var)
+
+exampleLE :: LambdaEnviroment
+exampleLE =
+  LambdaEnviroment
+    { functions =
+        Map.fromList
+          [ ((Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int))), ["(+)", "(-)", "(*)", "mod"]),
+            ((Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Bool))), ["(>)", "(==)", "(>=)"]),
+            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Int -> Int -> Int))), ["if'"])
+          ],
+      constants =
+        Map.fromList
+          [ ((Ref.SomeTypeRep (Ref.TypeRep @(Int))), [(fmap show (uniform 0 10000 :: RVar Int))]),
+            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool))), [(fmap show (uniform True False :: RVar Bool))])
+          ],
+      targetType = (Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int))),
+      maxDepth = 10,
+      weights =
+        ExpressionWeights
+          { lambdaSpucker = 1,
+            lambdaSchlucker = 2,
+            symbol = 2,
+            variable = 10,
+            constant = 2
+          }
+    }
+
+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
+
+-- LambdaSpucker - adds TypeRequester#1 as bound var and returns the result of TypeRequester#2
+
+data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show)
+
+asList :: LambdaExpression -> [TypeRequester]
+asList (LambdaSpucker tr1 tr2 _) = [tr1, tr2]
+asList (LambdaSchlucker tr _) = [tr]
+asList (Symbol _ trs _) = trs
+asList (Var _ _ trs _) = trs
+asList (Constan _) = []
+
+data TypeRequester = TR TypeRep (Maybe LambdaExpression) BoundVars deriving (Eq, Ord, Show)
+
+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)
+
+eToLambdaExpressionS :: LambdaExpression -> Text
+eToLambdaExpressionS (LambdaSpucker typeRequester1 typeRequester2 boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionS typeRequester2 <> ") " <> toLambdaExpressionS typeRequester1
+eToLambdaExpressionS (LambdaSchlucker typeRequester boundVars) = "\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionS typeRequester
+eToLambdaExpressionS (Symbol (valS) typeRequesters _) = valS <> " " <> (unwords (map toLambdaExpressionS typeRequesters))
+eToLambdaExpressionS (Var typeRep int typeRequesters _) = "l" <> showSanifid typeRep <> show int <> " " <> (unwords (map toLambdaExpressionS typeRequesters))
+eToLambdaExpressionS (Constan (valS)) = valS
+
+instance Pretty TypeRequester where
+  pretty = toLambdaExpressionShort
+
+instance Individual TypeRequester
+
+instance Pretty LambdaEnviroment where
+  pretty (LambdaEnviroment functions constants target _ _) = "Functions: " <> show functions <> " Constants: " <> show (Map.keys constants) <> " Target is a function: " <> show target
+
+genTypeRequester :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar TypeRequester
+genTypeRequester env depthLeft target boundVars = do
+  le <- genLambdaExpression env (depthLeft - 1) target boundVars
+  return (TR target (Just le) boundVars)
+
+genLambdaExpression :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
+genLambdaExpression env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do
+  let weightMap =
+        ( if not (canGenSchlucker target)
+            then [(constant weights, genLambdaConst env depthLeft target boundVar)]
+            else []
+        )
+          <> ( if depthLeft > 0
+                 then [(lambdaSpucker weights, genLambdaSpucker env depthLeft target boundVar)]
+                 else []
+             )
+          <> ( if canGenSchlucker target
+                 then [(lambdaSchlucker weights, genLambdaSchlucker env depthLeft target boundVar)]
+                 else []
+             )
+          <> ( if depthLeft > 0 && doAnyMatchThatType target (Map.keys functions)
+                 then [(symbol weights, genLambdaSymbol env depthLeft target boundVar)]
+                 else []
+             )
+          <> ( if depthLeft > 0 && doAnyMatchThatType target boundVar
+                 then [(variable weights, genLambdaVar env depthLeft target boundVar)]
+                 else []
+             )
+  expres <- selectWeighted weightMap
+  res <- expres
+  return res
+
+selectWeighted :: [(Int, a)] -> RVar a
+selectWeighted x = do
+  let total = sum (map fst x)
+  selection <- uniform 1 total
+  return $ selectAtWeight selection (NE.fromList x)
+
+selectAtWeight :: Int -> NonEmpty (Int, a) -> a
+selectAtWeight _ (x :| []) = snd x
+selectAtWeight w (x :| xs)
+  | fst x >= w = snd x
+  | otherwise = selectAtWeight (w - fst x) (NE.fromList xs)
+
+canGenSchlucker :: TypeRep -> Bool
+canGenSchlucker t = (typeRepTyCon t) == (typeRepTyCon (Ref.SomeTypeRep (Ref.TypeRep @(->))))
+
+doAnyMatchThatType :: TypeRep -> [TypeRep] -> Bool
+doAnyMatchThatType toGen available = any (doTypesMatch toGen) available
+
+doTypesMatch :: TypeRep -> TypeRep -> Bool
+doTypesMatch toGen available = elem toGen (available : (repeatedly (lastMay . typeRepArgs) available))
+
+genLambdaSpucker :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
+genLambdaSpucker env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do
+  lamdaTypeLength <- uniform 1 4
+  lambaTypes <- replicateM lamdaTypeLength (randomElement (Map.keys constants))
+  let lambaType = foldr1 mkFunTy lambaTypes
+  lamdaVarTypeRequester <- genTypeRequester env depthLeft lambaType boundVar
+  typeRequester <- genTypeRequester env depthLeft target (boundVar ++ [lambaType])
+  return (LambdaSpucker lamdaVarTypeRequester typeRequester (boundVar ++ [lambaType]))
+
+genLambdaSchlucker :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
+genLambdaSchlucker env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do
+  let args = typeRepArgs target
+  let lambaType = fromJust (head args)
+  let toFind = last args
+  typeRequester <- genTypeRequester env (depthLeft + 1) toFind (boundVar ++ [lambaType])
+  return (LambdaSchlucker typeRequester (boundVar ++ [lambaType]))
+
+genLambdaConst :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
+genLambdaConst env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do
+  elm <- randomElement $ fromJust (Map.lookup target constants)
+  res <- elm
+  return $ Constan res
+
+genLambdaSymbol :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
+genLambdaSymbol env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do
+  let availFunTypes = filter (doTypesMatch target) (Map.keys functions)
+  (tr, fun) <- randomElement $ concatMap (\l -> zip (repeat l) (fromMaybe [] (Map.lookup l functions))) availFunTypes
+  ret <- genLambdaSymbol' tr fun [] env depthLeft target boundVar
+  return ret
+
+genLambdaSymbol' :: TypeRep -> ConVal -> [TypeRequester] -> LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
+genLambdaSymbol' tr v trs env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar
+  | tr == target = do
+      return $ Symbol v trs boundVar
+  | otherwise = do
+      let args = typeRepArgs tr
+      let param = fromJust (head args)
+      let rest = last args
+      newTypeRequ <- genTypeRequester env depthLeft param boundVar
+      ret <- genLambdaSymbol' rest v (trs ++ [newTypeRequ]) env depthLeft target boundVar
+      return ret
+
+genLambdaVar :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
+genLambdaVar env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do
+  let availTypes = filter (doTypesMatch target) boundVar
+  choosenType <- randomElement $ availTypes
+  let tCount = count boundVar choosenType
+  indexV <- uniform 0 (tCount - 1)
+  ret <- genLambdaVar' choosenType choosenType indexV [] env depthLeft target boundVar
+  return ret
+
+genLambdaVar' :: TypeRep -> TypeRep -> Int -> [TypeRequester] -> LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
+genLambdaVar' tr varType varNumber trs env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar
+  | tr == target = do
+      return $ Var varType varNumber trs boundVar
+  | otherwise = do
+      let args = typeRepArgs tr
+      let param = fromJust (head args)
+      let rest = last args
+      newTypeRequ <- genTypeRequester env depthLeft param boundVar
+      ret <- genLambdaVar' rest varType varNumber (trs ++ [newTypeRequ]) env depthLeft target boundVar
+      return ret
+
+instance Environment TypeRequester LambdaEnviroment where
+  new env@(LambdaEnviroment _ _ target maxDepth _) = do
+    tr <- genTypeRequester env maxDepth target []
+    return tr
+
+  mutate env@(LambdaEnviroment _ _ _ maxDepth _) tr = do
+    selfCrossover <- uniform True False
+    co <- crossover1 env tr tr
+    if selfCrossover && isJust co
+      then do
+        let (tr1, tr2) = fromJust co
+        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
+    selectedIndex1 <- uniform 1 trCount
+    let (depthAt1, selectedTr1@(TR _ _ bound1)) = depthLeftAndTypeAtR tr1 selectedIndex1 maxDepth
+    let depthLeftNeeded = depthOfTR selectedTr1
+    let indexes = findIndicesWhere tr2 (isCompatibleTr selectedTr1 (maxDepth - depthAt1) depthLeftNeeded) 0 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)
+        )
+
+-- 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
+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
+convertTr tr@(TR tRp (Just le) bvCurr) bvOld bvNew mapper = TR tRp (Just (convertLe le bvOld bvNew mapper)) (bvNew ++ (bvCurr \\ bvOld))
+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"
+
+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"
+
+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"
+
+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"
+
+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"
+
+countTrsR :: TypeRequester -> Int
+countTrsR tr@(TR t lE _) = case lE of
+  Just le -> countTrs le + 1
+  Nothing -> 1
+
+countTrs :: LambdaExpression -> Int
+countTrs le = sum (map countTrsR (asList le))
+
+-- Test Stuff
+
+testConstInt :: TypeRequester
+testConstInt = TR (Ref.SomeTypeRep (Ref.TypeRep @Int)) (Just (Symbol ("5") [] [])) []
+
+testIntToClassCons :: TypeRequester
+testIntToClassCons = TR (Ref.SomeTypeRep (Ref.TypeRep @(Int -> ResClass))) (Just (Symbol ("Class1") [] [])) []
+
+testIntToClassCorrect :: TypeRequester
+testIntToClassCorrect =
+  TR
+    (Ref.SomeTypeRep (Ref.TypeRep @(Int -> ResClass)))
+    ( Just
+        ( LambdaSchlucker
+            ( TR
+                (Ref.SomeTypeRep (Ref.TypeRep @(ResClass)))
+                ( Just
+                    ( Symbol
+                        ("iteClass")
+                        [ ( TR
+                              (Ref.SomeTypeRep (Ref.TypeRep @(Bool)))
+                              ( Just
+                                  ( Symbol
+                                      ("eqInt")
+                                      [ ( TR
+                                            (Ref.SomeTypeRep (Ref.TypeRep @(Int)))
+                                            (Just (Var (Ref.SomeTypeRep (Ref.TypeRep @(Int))) 0 [] []))
+                                            [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                        ),
+                                        ( TR
+                                            (Ref.SomeTypeRep (Ref.TypeRep @(Int)))
+                                            (Just (Constan ("1")))
+                                            [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                        )
+                                      ]
+                                      [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                  )
+                              )
+                              [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                          ),
+                          ( TR
+                              (Ref.SomeTypeRep (Ref.TypeRep @(ResClass)))
+                              (Just (Constan ("Class1")))
+                              [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                          ),
+                          ( TR
+                              (Ref.SomeTypeRep (Ref.TypeRep @(ResClass)))
+                              ( Just
+                                  ( Symbol
+                                      ("iteClass")
+                                      [ ( TR
+                                            (Ref.SomeTypeRep (Ref.TypeRep @(Bool)))
+                                            ( Just
+                                                ( Symbol
+                                                    ("eqInt")
+                                                    [ ( TR
+                                                          (Ref.SomeTypeRep (Ref.TypeRep @(Int)))
+                                                          (Just (Var (Ref.SomeTypeRep (Ref.TypeRep @(Int))) 0 [] []))
+                                                          [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                      ),
+                                                      ( TR
+                                                          (Ref.SomeTypeRep (Ref.TypeRep @(Int)))
+                                                          (Just (Constan ("2")))
+                                                          [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                      )
+                                                    ]
+                                                    [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                )
+                                            )
+                                            [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                        ),
+                                        ( TR
+                                            (Ref.SomeTypeRep (Ref.TypeRep @(ResClass)))
+                                            (Just (Constan ("Class2")))
+                                            [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                        ),
+                                        ( TR
+                                            (Ref.SomeTypeRep (Ref.TypeRep @(ResClass)))
+                                            ( Just
+                                                ( Symbol
+                                                    ("iteClass")
+                                                    [ ( TR
+                                                          (Ref.SomeTypeRep (Ref.TypeRep @(Bool)))
+                                                          ( Just
+                                                              ( Symbol
+                                                                  ("eqInt")
+                                                                  [ ( TR
+                                                                        (Ref.SomeTypeRep (Ref.TypeRep @(Int)))
+                                                                        (Just (Var (Ref.SomeTypeRep (Ref.TypeRep @(Int))) 0 [] []))
+                                                                        [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                                    ),
+                                                                    ( TR
+                                                                        (Ref.SomeTypeRep (Ref.TypeRep @(Int)))
+                                                                        (Just (Constan ("3")))
+                                                                        [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                                    )
+                                                                  ]
+                                                                  [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                              )
+                                                          )
+                                                          [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                      ),
+                                                      ( TR
+                                                          (Ref.SomeTypeRep (Ref.TypeRep @(ResClass)))
+                                                          (Just (Constan ("Class3")))
+                                                          [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                      ),
+                                                      ( TR
+                                                          (Ref.SomeTypeRep (Ref.TypeRep @(ResClass)))
+                                                          (Just (Constan ("Class3")))
+                                                          [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                      )
+                                                    ]
+                                                    [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                )
+                                            )
+                                            [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                        )
+                                      ]
+                                      [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                  )
+                              )
+                              [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                          )
+                        ]
+                        [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                    )
+                )
+                [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+            )
+            [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+        )
+    )
+    []
+
+data ResClass = Class1 | Class2 | Class3 deriving (Enum, Show)
+
+eqInt :: Int -> Int -> Bool
+eqInt a b = a == b
+
+iteClass :: Bool -> ResClass -> ResClass -> ResClass
+iteClass True c _ = c
+iteClass False _ c = c
+
+toLambdaExpressionShort :: TypeRequester -> Text
+toLambdaExpressionShort (TR _ (Just lambdaExpression) _) = "(" <> eToLambdaExpressionShort lambdaExpression <> ")"
+toLambdaExpressionShort (TR _ (Nothing) _) = "Invalid Lambda Epr"
+
+-- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int | Constan ConVal
+
+eToLambdaExpressionShort :: LambdaExpression -> Text
+eToLambdaExpressionShort (LambdaSpucker typeRequester1 typeRequester2 boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionShort typeRequester2 <> ") " <> toLambdaExpressionShort typeRequester1
+eToLambdaExpressionShort (LambdaSchlucker typeRequester boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionShort typeRequester <> ")"
+eToLambdaExpressionShort (Symbol (valS) typeRequesters _) = valS <> " " <> (unwords (map toLambdaExpressionShort typeRequesters))
+eToLambdaExpressionShort (Var typeRep int typeRequesters _) = "l" <> showSanifid typeRep <> show int <> " " <> (unwords (map toLambdaExpressionShort typeRequesters))
+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))

lib/Test.hs

@@ -0,0 +1,21 @@
+{-# 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

@@ -0,0 +1,60 @@
+{-# 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

@@ -0,0 +1,9 @@
+#!/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/Main.hs

@@ -5,14 +5,14 @@
 import Options.Applicative
 import Pipes
 import Pretty
-import Protolude hiding (for, option)
+import Protolude hiding (for)
 import System.IO
--- import Szenario212Pun
+import Seminar
-import Szenario222
+import Szenario191
 
 data Options = Options
-  { iterations :: N,
+  { iterations :: !N,
-    populationSize :: N
+    populationSize :: !N
   }
 
 options :: Parser Options
@@ -23,7 +23,7 @@ options =
       ( long "iterations"
           <> short 'i'
           <> metavar "N"
-          <> value 1000
+          <> value 1500
           <> help "Number of iterations"
       )
     <*> option
@@ -31,7 +31,7 @@ options =
       ( long "population-size"
           <> short 'p'
           <> metavar "N"
-          <> value 100
+          <> value 400
           <> help "Population size"
       )
 
@@ -48,15 +48,23 @@ main :: IO ()
 main =
   execParser optionsWithHelp >>= \opts -> do
     hSetBuffering stdout NoBuffering
-    pop <- population (populationSize opts) (I prios [])
+    let cfg = GaRunConfig {
-    pop' <-
+      enviroment = AssignmentEnviroment (students prios, topics prios),
-      runEffect $
+      initialEvaluator = prios,
-        for (run (tournament 2) 2 1 (5 / 100) pop (steps $ iterations opts)) log
+      selectionType = Tournament 3,
-    (res, _) <- bests 5 pop'
+      termination = (steps (iterations opts)),
-    sequence_ $ format <$> res
+      poulationSize = (populationSize opts),
+      stepSize = 120,
+      elitismRatio = 5/100
+    }
+    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 s = do
+    format seminarL s = do
-      f <- liftIO $ fitness s
+      let f = fitness' seminarL s
       putErrText $ show f <> "\n" <> pretty s
-    log = putText . csv
+    logCsv = putText . csv
     csv (t, f) = show t <> " " <> show f

src-students/Seminar.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 
 module Seminar where
 
@@ -96,20 +97,55 @@ prop_prioOf_singletonNotFound =
 lowestPriority :: Priorities -> Int
 lowestPriority = fromMaybe 0 . maximumMay . fmap snd . join . fmap snd . unP
 
-type Assignment = [(Maybe Student, Maybe Topic)]
+type Assignment = [(Maybe Student, Maybe  Topic)]
 
-data I = I Priorities Assignment
+instance Individual Assignment
-  deriving (Eq, Show)
 
-instance Pretty I where
+newtype AssignmentEnviroment = AssignmentEnviroment ([Student],[Topic]) deriving Eq
-  pretty (I p a) =
+
+instance Pretty AssignmentEnviroment where
+  pretty (AssignmentEnviroment (persons,assignables)) = "Persons: " <> show persons <> " Assignables: " <> show assignables
+
+instance Environment Assignment AssignmentEnviroment where
+  new (AssignmentEnviroment (persons,assignables)) = do
+    let aPadding = replicate (length persons - length assignables) Nothing
+    let paddedAssignables = (Just <$> assignables) ++ aPadding
+    let pPadding = replicate (length assignables - length persons) Nothing
+    let paddedPersons = (Just <$> persons) ++ pPadding
+
+    mixedAssignables <- shuffle paddedAssignables
+    return $ zip paddedPersons mixedAssignables
+
+  nX _ = 1
+
+  mutate _ assignment = do
+    x <- uniform 0 (length assignment - 1)
+    y <- uniform 0 (length assignment - 1)
+    return $ switch x y assignment
+
+  -- \|
+  --  Borrowed from TSP: Crossover cuts the parents in two and swaps them (if this
+  --  does not create an invalid offspring).
+  --
+  crossover1 e assignment1 assignment2 = do
+    let l = fromIntegral $ min (length assignment1) (length assignment2) :: Double
+    x <- uniform 0 l
+    let assignment1' = zipWith3 (f x) assignment1 assignment2 [0 ..]
+    let assignment2' = zipWith3 (f x) assignment2 assignment1 [0 ..]
+    if valid e assignment1' && valid e assignment2'
+      then return . Just $ ( assignment1', assignment2')
+      else return Nothing
+    where
+      f x v1 v2 i = if i <= x then v1 else v2
+
+
+instance Pretty Assignment where
+  pretty (a) =
     T.unlines (gene <$> a)
     where
       gene :: (Maybe Student, Maybe Topic) -> Text
       gene (s, t) =
-        pretty s <> ": " <> pretty t <> prio s t
+        pretty s <> ": " <> pretty t
-      prio :: Maybe Student -> Maybe Topic -> Text
-      prio s t = " (" <> show (prioOf' p s t) <> ")"
 
 -- |
 -- The priority value given by a student to a topic including the case of her not
@@ -117,44 +153,13 @@ instance Pretty I where
 prioOf' :: Priorities -> Maybe Student -> Maybe Topic -> Int
 -- TODO Maybe make this neutral?
 prioOf' p Nothing Nothing = lowestPriority p + 2
-prioOf' p (Just s) Nothing = lowestPriority p + 2
+prioOf' p (Just _) Nothing = lowestPriority p + 2
-prioOf' p Nothing (Just t) = lowestPriority p + 2
+prioOf' p Nothing (Just _) = lowestPriority p + 2
 prioOf' p (Just s) (Just t) = prioOf p s t
 
-instance Individual I where
+instance Evaluator Assignment Priorities R where
-  new (I p _) =
+  fitness' prio assment =
-    sample $ I p . zip students' <$> shuffle topics'
+    negate . sum $ fromIntegral . uncurry (prioOf' prio) <$> assment
-    where
-      topics' = (Just <$> topics p) ++ tPadding
-      tPadding = replicate (length (students p) - length (topics p)) Nothing
-      students' = (Just <$> students p) ++ sPadding
-      sPadding = replicate (length (topics p) - length (students p)) Nothing
-
-  fitness (I p a) =
-    return . negate . sum $
-      fromIntegral . uncurry (prioOf' p) <$> a
-
-  mutate (I p a) = do
-    x <- sample $ Uniform 0 (length a - 1)
-    y <- sample $ Uniform 0 (length a - 1)
-    return . I p $ switch x y a
-
-  -- \|
-  --  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 (I p a1) (I _ a2) = do
-    let l = fromIntegral $ min (length a1) (length a2) :: Double
-    x <- sample $ Uniform 0 l
-    let a1' = zipWith3 (f x) a1 a2 [0 ..]
-    let a2' = zipWith3 (f x) a2 a1 [0 ..]
-    if valid p a1' && valid p a2'
-      then return . Just $ (I p a1', I p a2')
-      else return Nothing
-    where
-      f x v1 v2 i = if i <= x then v1 else v2
 
 -- |
 -- Swaps topics at positions 'i'' and 'j'' in the given assignment.
@@ -162,14 +167,10 @@ switch :: Int -> Int -> Assignment -> Assignment
 switch i' j' xs
   | i' == j' = xs
   | 0 <= i' && i' < length xs && 0 <= j' && j' < length xs =
-      let i = min i' j'
+    zipWith (\ind y ->
-          j = max i' j'
+    if ind == i' then (fst y, snd (xs !! j'))
-          ei = xs !! i
+    else if ind == j' then (fst y, snd (xs !! i'))
-          ej = xs !! j
+    else y) [0..] xs
-          left = take i xs
-          middle = take (j - i - 1) $ drop (i + 1) xs
-          right = drop (j + 1) xs
-       in left ++ [(fst ei, snd ej)] ++ middle ++ [(fst ej, snd ei)] ++ right
   | otherwise = xs
 
 -- |
@@ -178,10 +179,10 @@ switch i' j' xs
 -- less topics than students).
 --
 -- Assumes that the priorities are well-formed.
-valid :: Priorities -> Assignment -> Bool
+valid :: AssignmentEnviroment -> Assignment -> Bool
-valid p a =
+valid (AssignmentEnviroment (persons,assignables)) a =
   -- all students must be part of the solution
-  sort (students p) == (catMaybes $ sort studentsAssigned)
+  sort (persons) == (catMaybes $ sort studentsAssigned)
     -- each actual topic (i.e. not “no topic”) is assigned at most once
     && nubOrd (delete Nothing topicsAssigned) == delete Nothing topicsAssigned
   where

src-students/Test.hs

@@ -0,0 +1,21 @@
+{-# 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

@@ -1,379 +0,0 @@
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
--- |
--- Module      : GA
--- Description : Abstract genetic algorithm
--- Copyright   : David Pätzel, 2019
--- License     : GPL-3
--- Maintainer  : David Pätzel <david.paetzel@posteo.de>
--- Stability   : experimental
---
--- Simplistic abstract definition of a genetic algorithm.
---
--- 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 where
-
-import Control.Arrow hiding (first, second)
-import Data.List.NonEmpty ((<|))
-import qualified Data.List.NonEmpty as NE
-import qualified Data.List.NonEmpty.Extra as NE (appendl, sortOn)
-import Data.Random
-import Pipes
-import Protolude
-import Test.QuickCheck hiding (sample, shuffle)
-import Test.QuickCheck.Instances ()
-import Test.QuickCheck.Monadic
-
--- TODO there should be a few 'shuffle's here
-
--- TODO enforce this being > 0
-type N = Int
-
-type R = Double
-
-class Eq i => Individual i where
-  -- |
-  --  Generates a completely random individual given an existing individual.
-  --
-  --  We have to add @i@ here as a parameter in order to be able to inject stuff.
-
-  -- TODO This (and also, Seminar.I, which contains an ugly parameter @p@) has
-  -- to be done nicer!
-  new :: (MonadRandom m) => i -> m i
-
-  -- |
-  --  Generates a random population of the given size.
-  population :: (MonadRandom m) => N -> i -> m (Population i)
-  population n i
-    | n <= 0 = undefined
-    | otherwise = NE.fromList <$> replicateM n (new i)
-
-  mutate :: (MonadRandom m) => i -> m i
-
-  crossover1 :: (MonadRandom m) => i -> i -> m (Maybe (i, i))
-
-  -- |
-  --  An individual's fitness. Higher values are considered “better”.
-  --
-  --  We explicitely allow fitness values to be have any sign (see, for example,
-  --  'proportionate1').
-  fitness :: (Monad m) => i -> m R
-
-  -- |
-  --  Performs an n-point crossover.
-  --
-  --  Given the function for single-point crossover, 'crossover1', this function can
-  --  be derived through recursion and a monad combinator (which is also the default
-  --  implementation).
-  crossover :: (MonadRandom m) => N -> i -> i -> m (Maybe (i, i))
-  crossover n i1 i2
-    | n <= 0 = return $ Just (i1, i2)
-    | otherwise = do
-        isM <- crossover1 i1 i2
-        maybe (return Nothing) (uncurry (crossover (n - 1))) isM
-
--- |
--- Needed for QuickCheck tests, for now, a very simplistic implementation should
--- suffice.
-instance Individual Integer where
-  new _ = sample $ uniform 0 (0 + 100000)
-
-  mutate i = sample $ uniform (i - 10) (i + 10)
-
-  crossover1 i1 i2 = return $ Just (i1 - i2, i2 - i1)
-
-  fitness = return . fromIntegral . negate
-
--- |
--- Populations are just basic non-empty lists.
-type Population i = NonEmpty i
-
--- |
--- Produces offspring circularly from the given list of parents.
-children ::
-  (Individual i, MonadRandom m) =>
-  -- | The @nX@ of the @nX@-point crossover operator
-  N ->
-  NonEmpty i ->
-  m (NonEmpty i)
-children _ (i :| []) = (:| []) <$> mutate i
-children nX (i1 :| [i2]) = children2 nX i1 i2
-children nX (i1 :| i2 : is') =
-  (<>) <$> children2 nX i1 i2 <*> children nX (NE.fromList is')
-
-prop_children_asManyAsParents ::
-  (Individual a, Show a) => N -> NonEmpty a -> Property
-prop_children_asManyAsParents nX is =
-  again $
-    monadicIO $
-      do
-        is' <- lift $ children nX is
-        return $ counterexample (show is') $ length is' == length is
-
-children2 :: (Individual i, MonadRandom m) => N -> i -> i -> m (NonEmpty i)
-children2 nX i1 i2 = do
-  -- TODO Add crossover probability?
-  (i3, i4) <- fromMaybe (i1, i2) <$> crossover nX i1 i2
-  i5 <- mutate i3
-  i6 <- mutate i4
-  return $ i5 :| [i6]
-
--- |
--- The best according to a function; returns up to @k@ results and the remaining
--- population.
---
--- If @k <= 0@, this returns the best one anyway (as if @k == 1@).
-bestsBy ::
-  (Individual i, Monad m) =>
-  N ->
-  (i -> m R) ->
-  Population i ->
-  m (NonEmpty i, [i])
-bestsBy k f pop@(i :| pop')
-  | k <= 0 = bestsBy 1 f pop
-  | otherwise = foldM run (i :| [], []) pop'
-  where
-    run (bests, rest) i =
-      ((NE.fromList . NE.take k) &&& (rest <>) . NE.drop k)
-        <$> sorted (i <| bests)
-    sorted =
-      fmap (fmap fst . NE.sortOn (Down . snd)) . traverse (\i -> (i,) <$> f i)
-
--- |
--- The @k@ best individuals in the population when comparing using the supplied
--- function.
-bestsBy' :: (Individual i, Monad m) => N -> (i -> m R) -> Population i -> m [i]
-bestsBy' k f =
-  fmap (NE.take k . fmap fst . NE.sortBy (comparing (Down . snd)))
-    . traverse (\i -> (i,) <$> f i)
-
-prop_bestsBy_isBestsBy' :: Individual a => Int -> Population a -> Property
-prop_bestsBy_isBestsBy' k pop =
-  k > 0 ==>
-    monadicIO $
-      do
-        a <- fst <$> bestsBy k fitness pop
-        b <- bestsBy' k fitness pop
-        assert $ NE.toList a == b
-
-prop_bestsBy_lengths :: Individual a => Int -> Population a -> Property
-prop_bestsBy_lengths k pop =
-  k > 0 ==> monadicIO $ do
-    (bests, rest) <- bestsBy k fitness pop
-    assert $
-      length bests == min k (length pop) && length bests + length rest == length pop
-
--- |
--- The @k@ worst individuals in the population (and the rest of the population).
-worst :: (Individual i, Monad m) => N -> Population i -> m (NonEmpty i, [i])
-worst = flip bestsBy (fmap negate . fitness)
-
--- |
--- The @k@ best individuals in the population (and the rest of the population).
-bests :: (Individual i, Monad m) => N -> Population i -> m (NonEmpty i, [i])
-bests = flip bestsBy fitness
-
--- TODO add top x percent parent selection (select n guys, sort by fitness first)
-
--- |
--- Performs one iteration of a steady state genetic algorithm that in each
--- iteration that creates @k@ offspring simply deletes the worst @k@ individuals
--- while making sure that the given percentage of elitists survive (at least 1
--- elitist, even if the percentage is 0 or low enough for rounding to result in 0
--- elitists).
-stepSteady ::
-  (Individual i, MonadRandom m, Monad m) =>
-  -- | Mechanism for selecting parents
-  Selection m i ->
-  -- | Number of parents @nParents@ for creating @nParents@ children
-  N ->
-  -- | How many crossover points (the @nX@ in @nX@-point crossover)
-  N ->
-  -- | Elitism ratio @pElite@
-  R ->
-  Population i ->
-  m (Population i)
-stepSteady select nParents nX pElite pop = do
-  -- TODO Consider keeping the fitness evaluations already done for pop (so we
-  -- only reevaluate iChildren)
-  iParents <- select nParents pop
-  iChildren <- NE.filter (`notElem` pop) <$> children nX iParents
-  let pop' = pop `NE.appendl` iChildren
-  (elitists, rest) <- bests nBest pop'
-  case rest of
-    [] -> return elitists
-    (i : is) ->
-      -- NOTE 'bests' always returns at least one individual, thus we need this
-      -- slightly ugly branching
-      if length elitists == length pop
-        then return elitists
-        else
-          (elitists <>)
-            . fst
-            <$> bests (length pop - length elitists) (i :| is)
-  where
-    nBest = floor . (pElite *) . fromIntegral $ NE.length pop
-
-prop_stepSteady_constantPopSize ::
-  (Individual a, Show a) => NonEmpty a -> Property
-prop_stepSteady_constantPopSize pop =
-  forAll
-    ( (,)
-        <$> choose (1, length pop)
-        <*> choose (1, length pop)
-    )
-    $ \(nParents, nX) -> monadicIO $ do
-      let pElite = 0.1
-      pop' <- lift $ stepSteady (tournament 4) nParents nX pElite pop
-      return . counterexample (show pop') $ length pop' == length pop
-
--- |
--- Given an initial population, runs the GA until the termination criterion is
--- fulfilled.
---
--- Uses the pipes library to, in each step, 'Pipes.yield' the currently best known
--- solution.
-run ::
-  (Individual i, Monad m, MonadRandom m) =>
-  -- | Mechanism for selecting parents
-  Selection m i ->
-  -- | Number of parents @nParents@ for creating @nParents@ children
-  N ->
-  -- | How many crossover points (the @nX@ in @nX@-point crossover)
-  N ->
-  -- | Elitism ratio @pElite@
-  R ->
-  Population i ->
-  Termination i ->
-  Producer (Int, R) m (Population i)
-run select nParents nX pElite pop term = step' 0 pop
-  where
-    step' t pop
-      | term pop t = return pop
-      | otherwise = do
-          pop' <- lift $ stepSteady select nParents nX pElite pop
-          (iBests, _) <- lift $ bests 1 pop'
-          fs <- lift . sequence $ fitness <$> iBests
-          let fBest = NE.head fs
-          Pipes.yield (t, fBest)
-          step' (t + 1) pop'
-
--- * Selection mechanisms
-
--- |
--- A function generating a monadic action which selects a given number of
--- individuals from the given population.
-type Selection m i = N -> Population i -> m (NonEmpty i)
-
--- |
--- Selects @n@ individuals from the population the given mechanism by repeatedly
--- selecting a single individual using the given selection mechanism (with
--- replacement, so the same individual can be selected multiple times).
-chain ::
-  (Individual i, MonadRandom m) =>
-  (Population i -> m i) ->
-  Selection m i
--- TODO Ensure that the same individual is not selected multiple times
--- (require Selections to partition)
-chain select1 n pop
-  | n > 1 = (<|) <$> select1 pop <*> chain select1 (n - 1) pop
-  | otherwise = (:|) <$> select1 pop <*> return []
-
--- |
--- Selects @n@ individuals from the population by repeatedly selecting a single
--- indidual using a tournament of the given size (the same individual can be
--- selected multiple times, see 'chain').
-tournament :: (Individual i, MonadRandom m) => N -> Selection m i
-tournament nTrnmnt = chain (tournament1 nTrnmnt)
-
-prop_tournament_selectsN :: Individual a => Int -> Int -> NonEmpty a -> Property
-prop_tournament_selectsN nTrnmnt n pop =
-  0 < nTrnmnt
-    && nTrnmnt < length pop
-    && 0 < n
-    ==> monadicIO
-    $ do
-      pop' <- lift $ tournament 2 n pop
-      assert $ length pop' == n
-
--- |
--- Selects one individual from the population using tournament selection.
-tournament1 ::
-  (Individual i, MonadRandom m) =>
-  -- | Tournament size
-  N ->
-  Population i ->
-  m i
-tournament1 nTrnmnt pop
-  -- TODO Use Positive for this constraint
-  | nTrnmnt <= 0 = undefined
-  | otherwise = trnmnt >>= fmap (NE.head . fst) . bests 1
-  where
-    trnmnt = withoutReplacement nTrnmnt pop
-
--- |
--- Selects @n@ individuals uniformly at random from the population (without
--- replacement, so if @n >= length pop@, simply returns @pop@).
-withoutReplacement ::
-  (MonadRandom m) =>
-  -- | How many individuals to select
-  N ->
-  Population i ->
-  m (NonEmpty i)
-withoutReplacement 0 _ = undefined
-withoutReplacement n pop
-  | n >= length pop = return pop
-  | otherwise =
-      fmap NE.fromList . sample . shuffleNofM n (length pop) $ NE.toList pop
-
-prop_withoutReplacement_selectsN :: Int -> NonEmpty a -> Property
-prop_withoutReplacement_selectsN n pop =
-  0 < n && n <= length pop ==> monadicIO $ do
-    pop' <- lift $ withoutReplacement n pop
-    assert $ length pop' == n
-
--- * Termination criteria
-
--- |
--- Termination decisions may take into account the current population and the
--- current iteration number.
-type Termination i = Population i -> N -> Bool
-
--- |
--- Termination after a number of steps.
-steps :: N -> Termination i
-steps tEnd _ t = t >= tEnd
-
--- * Helper functions
-
--- |
--- Shuffles a non-empty list.
-shuffle' :: (MonadRandom m) => NonEmpty a -> m (NonEmpty a)
-shuffle' xs@(_ :| []) = return xs
-shuffle' xs = do
-  i <- sample . uniform 0 $ NE.length xs - 1
-  -- slightly unsafe (!!) used here so deletion is faster
-  let x = xs NE.!! i
-  xs' <- sample . shuffle $ deleteI i xs
-  return $ x :| xs'
-  where
-    deleteI i xs = fst (NE.splitAt i xs) ++ snd (NE.splitAt (i + 1) xs)
-
-prop_shuffle_length :: NonEmpty a -> Property
-prop_shuffle_length xs = monadicIO $ do
-  xs' <- lift $ shuffle' xs
-  assert $ length xs' == length xs
-
-return []
-
-runTests :: IO Bool
-runTests = $quickCheckAll

src/Test.hs

@@ -1,13 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Main where
-
-import qualified GA
-import Protolude
-import qualified Seminar
-
-main :: IO ()
-main = do
-  _ <- GA.runTests
-  _ <- Seminar.runTests
-  return ()

stack.yaml

@@ -0,0 +1,66 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-21.13
+# resolver: nightly-2023-09-24
+# resolver: ghc-9.6.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2023-01-01.yaml
+resolver: nightly-2024-02-11
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+#   subdirs:
+#   - auto-update
+#   - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver.
+# These entries can reference officially published versions as well as
+# forks / in-progress versions pinned to a git hash. For example:
+#
+# extra-deps:
+# - acme-missiles-0.3
+# - git: https://github.com/commercialhaskell/stack.git
+#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of Stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=2.13"
+#
+# Override the architecture used by Stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by Stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor

stack.yaml.lock

@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    sha256: 3693cc17b3c739a22032b7c7bf44aa7ddbeef79311bb9f175e68372f92fc749b
+    size: 600684
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2024/2/11.yaml
+  original: nightly-2024-02-11