LamdaCalculusV2

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,
-        "narHash": "sha256-7g1zwTdp35GMTERnSzZMWJ7PG3QdDE8VOX3WsnOkAtM=",
+        "lastModified": 1713145326,
+        "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/0d68d7c857fe301d49cdcd56130e0beea4ecd5aa";
+      "github:NixOS/nixpkgs/53a2c32bc66f5ae41a28d7a9a49d321172af621e";
 
   };
 
@@ -14,10 +13,12 @@
       # defaultPackage.${system} = haskellPackages.callPackage ./default.nix { };
       devShell.${system} = mkShell {
         buildInputs = [
+          haskell.compiler.ghc981
+          git
+          gcc
+          gmp
           feedgnuplot
-          haskellPackages.cabal-install
-          haskellPackages.ormolu
-          haskell.compiler.ghc8107
+          stack
         ];
       };
     };

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
@@ -30,6 +30,7 @@ library
                      , MonadRandom
                      , mwc-random
                      , optparse-applicative
+                     , parallel
                      , path
                      , pipes
                      , primitive
@@ -39,30 +40,35 @@ library
                      , random
                      , random-fu
                      , random-shuffle
+                     , semirings
                      , text
                      , wl-pprint-text
   default-language:    Haskell2010
-  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
-  hs-source-dirs:      src
+  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans -O2
+  hs-source-dirs:      lib, lambda/lib
+  other-modules:       CommonDefinition
   exposed-modules:     GA
-                     , Seminar
-                     , Pretty
-                     , Szenario191
                      , LambdaCalculus
-                     , IrisDataset
-                     , IrisData
+                     , LambdaCalculusV2
+                     , Pretty
+                     , Utils
+                     , LambdaDatasets.NurseryDefinition
+                     , LambdaDatasets.GermanDefinition
+                     , LambdaDatasets.IrisDefinition
 
-executable haga
+executable haga-lambda
   build-depends:       base
                      , bytestring
                      , cassava
                      , containers
                      , extra
                      , hint
+                     , haga
                      , monad-loops
                      , MonadRandom
                      , mwc-random
                      , optparse-applicative
+                     , parallel
                      , path
                      , pipes
                      , primitive
@@ -76,15 +82,32 @@ executable haga
                      , wl-pprint-text
   default-language:    Haskell2010
   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
-                     , Seminar
-                     , Pretty
+  other-modules:       LambdaDatasets.NurseryDataset
+                     , LambdaDatasets.NurseryData
+                     , 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
-                     , LambdaCalculus
-                     , IrisDataset
-                     , IrisData
 
 executable haga-test
   build-depends:       base
@@ -93,11 +116,13 @@ executable haga-test
                      , cassava
                      , containers
                      , extra
+                     , haga
                      , hint
                      , monad-loops
                      , MonadRandom
                      , mwc-random
                      , optparse-applicative
+                     , parallel
                      , path
                      , pipes
                      , primitive
@@ -111,12 +136,5 @@ executable haga-test
                      , wl-pprint-text
   default-language:    Haskell2010
   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
-                     , LambdaCalculus
-                     , IrisDataset
-                     , IrisData

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,40 @@
+{-# 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)
+instance Hashable NurseryClass
+
+data Parents = Usual | Pretentious | GreatPret deriving (Eq, Generic, Show, Enum, Bounded, Ord)
+instance Hashable Parents
+
+data HasNurs = ProperNurs | LessProperNurs | ImproperNurs | CriticalNurs | VeryCritNurs deriving (Eq, Generic, Show, Enum, Bounded, Ord)
+instance Hashable HasNurs
+
+data Form    = CompleteFamilyForm | CompletedFamilyForm | IncompleteFamilyForm | FosterFamilyForm deriving (Eq, Generic, Show, Enum, Bounded, Ord)
+instance Hashable Form
+
+data Children = OneChild | TwoChilds | ThreeChilds | MoreChilds deriving (Eq, Generic, Show, Enum, Bounded, Ord)
+instance Hashable Children
+
+data Housing = ConvenientHousing | LessConvHousing | CriticalHousing deriving (Eq, Generic, Show, Enum, Bounded, Ord)
+instance Hashable Housing
+
+data Finance = ConvenientFinance | InconvFinance deriving (Eq, Generic, Show, Enum, Bounded, Ord)
+instance Hashable Finance
+
+data Social = NotProblematicSocial | SlightlyProblematicSocial | ProblematicSocial deriving (Eq, Generic, Show, Enum, Bounded, Ord)
+instance Hashable Social
+
+data Health = NotRecommendHealth |RecommendedHealth | PriorityHealth  deriving (Eq, Generic, Show, Enum, Bounded, Ord)
+instance Hashable Health

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 Enums
+            ((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 Enum
+            ((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'","if'","if'","if'","if'","if'","if'","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 = 8,
+      weights =
+        ExpressionWeights
+          { lambdaSpucker = 1,
+            lambdaSchlucker = 2,
+            symbol = 30,
+            variable = 10,
+            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 = score,
+          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

@@ -4,17 +4,15 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module IrisData where
+module LambdaDatasets.IrisData
+  ( module LambdaDatasets.IrisDefinition,
+    module LambdaDatasets.IrisData,
+  )
+where
 
-import Data.Csv
+import LambdaDatasets.IrisDefinition
 import Protolude
 
-data IrisClass = Setosa | Virginica | Versicolor deriving (Eq, Generic, Show, Enum, Bounded)
-
-instance FromRecord IrisClass
-
-instance ToRecord IrisClass
-
 irisTrainingData :: [((Float, Float, Float, Float), IrisClass)]
 irisTrainingData =
   [ ((6.7, 3.1, 4.4, 1.4), Versicolor),
@@ -136,12 +134,8 @@ irisTrainingData =
     ((5.7, 2.5, 5.0, 2.0), Virginica),
     ((6.8, 2.8, 4.8, 1.4), Versicolor),
     ((6.3, 2.9, 5.6, 1.8), Virginica),
-    ((6.0, 2.2, 4.0, 1.0), Versicolor)
-  ]
-
-irisTestData :: [((Float, Float, Float, Float), IrisClass)]
-irisTestData =
-  [ ((5.0, 3.5, 1.6, 0.6), Setosa),
+    ((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),

lambda/src/LambdaDatasets/IrisDataset.hs

@@ -4,10 +4,10 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module IrisDataset
+module LambdaDatasets.IrisDataset
   ( module LambdaCalculus,
-    module IrisDataset,
-    module IrisData,
+    module LambdaDatasets.IrisDataset,
+    module LambdaDatasets.IrisData,
     module GA,
   )
 where
@@ -15,20 +15,22 @@ 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 IrisData
+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
 
-irisLE :: LambdaEnviroment
-irisLE =
+lE :: LambdaEnviroment
+lE =
   LambdaEnviroment
     { functions =
         Map.fromList
@@ -57,22 +59,42 @@ irisLE =
           }
     }
 
-irisLEE :: LamdaExecutionEnv
-irisLEE =
+lEE :: LamdaExecutionEnv
+lEE =
   LamdaExecutionEnv
     { -- For now these need to define all available functions and types. Generic functions can be used.
-      imports = ["IrisDataset"],
+      imports = ["LambdaDatasets.IrisDataset"],
       training = True,
       trainingData =
-        ( map fst irisTrainingData,
-          map snd irisTrainingData
+        ( map fst (takeFraktion 0.8 irisTrainingData),
+          map snd (takeFraktion 0.8 irisTrainingData)
         ),
       testData =
-        ( map fst irisTestData,
-          map snd irisTestData
+        ( 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.IrisDataset"],
+      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))),
-      -- todo: kindaHacky
       results = Map.empty
     }
 
@@ -92,8 +114,9 @@ data FittnesRes = FittnesRes
     fitnessTotal :: R,
     fitnessGeoMean :: R,
     fitnessMean :: R,
-    accuracy :: Int,
-    biasSize :: R
+    accuracy :: R,
+    biasSize :: R,
+    totalSize :: N
   }
   deriving (Show)
 
@@ -104,42 +127,42 @@ instance Evaluator TypeRequester LamdaExecutionEnv FittnesRes where
   fitness' env tr = (results env) Map.! tr
 
   calc env pop = do
-    let toAdd = NE.filter (\k -> not (Map.member k (results env))) pop
+    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 (results env) (fromRight (error ("To insert is " <> show toInsert)) toInsert)
+    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 = mapM (evalResult ex) trs
-
-evalResult :: LamdaExecutionEnv -> TypeRequester -> Hint.InterpreterT IO (TypeRequester, FittnesRes)
-evalResult ex tr = do
+evalResults ex trs = do
   Hint.setImports $ (map T.unpack (imports ex)) ++ ["Protolude"]
   Hint.unsafeSetGhcOption "-O2"
-  result <- Hint.interpret (T.unpack (toLambdaExpressionS tr)) (Hint.as :: Float -> Float -> Float -> Float -> IrisClass)
-  let res = map (\(a, b, c, d) -> result a b c d) (fst (dset ex))
-  let resAndTarget = (zip (snd (dset ex)) res)
-  let acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) :: Int
-  let biasSmall = exp ((-(fromIntegral (countTrsR tr)))/1000) -- 0 (schlecht) bis 1 (gut)
-  let fitness' = meanOfAccuricyPerClass resAndTarget
-  let score = fitness' + (biasSmall - 1)
-  return
-    ( tr,
+  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 = score,
           fitnessTotal = fitness',
           fitnessMean = meanOfAccuricyPerClass resAndTarget,
           fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
           accuracy = acc,
-          biasSize = biasSmall
+          biasSize = biasSmall,
+          totalSize = countTrsR tr
         }
     )
-
-if' :: Bool -> a -> a -> a
-if' True e _ = e
-if' False _ e = e
-
+    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,139 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module LambdaDatasets.NurseryDataset
+  ( module LambdaCalculusV2,
+    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 LambdaCalculusV2
+import LambdaDatasets.NurseryData
+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
+
+operators :: [BoundSymbol]
+operators = [ -- Math
+          -- Logic
+          BoundSymbol (Ref.TypeRep @(Bool -> Bool -> Bool)) (&&) (Just "(&&)"),
+          BoundSymbol (Ref.TypeRep @(Bool -> Bool -> Bool)) (||) (Just "(||)"),
+          -- Ordered Enums
+          BoundSymbol (Ref.TypeRep @(NurseryClass -> NurseryClass -> Bool)) (>) (Just "(>)"),
+          BoundSymbol (Ref.TypeRep @(NurseryClass -> NurseryClass -> Bool)) (==) (Just "(==)"),
+          BoundSymbol (Ref.TypeRep @(NurseryClass -> NurseryClass -> Bool)) (/=) (Just "(/=)"),
+          BoundSymbol (Ref.TypeRep @(NurseryClass -> NurseryClass -> Bool)) (>=) (Just "(>=)"),
+          BoundSymbol (Ref.TypeRep @(Parents -> Parents -> Bool)) (>) (Just "(>)"),
+          BoundSymbol (Ref.TypeRep @(Parents -> Parents -> Bool)) (==) (Just "(==)"),
+          BoundSymbol (Ref.TypeRep @(Parents -> Parents -> Bool)) (/=) (Just "(/=)"),
+          BoundSymbol (Ref.TypeRep @(Parents -> Parents -> Bool)) (>=) (Just "(>=)"),
+          BoundSymbol (Ref.TypeRep @(HasNurs -> HasNurs -> Bool)) (>) (Just "(>)"),
+          BoundSymbol (Ref.TypeRep @(HasNurs -> HasNurs -> Bool)) (==) (Just "(==)"),
+          BoundSymbol (Ref.TypeRep @(HasNurs -> HasNurs -> Bool)) (/=) (Just "(/=)"),
+          BoundSymbol (Ref.TypeRep @(HasNurs -> HasNurs -> Bool)) (>=) (Just "(>=)"),
+          BoundSymbol (Ref.TypeRep @(Form -> Form -> Bool)) (>) (Just "(>)"),
+          BoundSymbol (Ref.TypeRep @(Form -> Form -> Bool)) (==) (Just "(==)"),
+          BoundSymbol (Ref.TypeRep @(Form -> Form -> Bool)) (/=) (Just "(/=)"),
+          BoundSymbol (Ref.TypeRep @(Form -> Form -> Bool)) (>=) (Just "(>=)"),
+          BoundSymbol (Ref.TypeRep @(Children -> Children -> Bool)) (>) (Just "(>)"),
+          BoundSymbol (Ref.TypeRep @(Children -> Children -> Bool)) (==) (Just "(==)"),
+          BoundSymbol (Ref.TypeRep @(Children -> Children -> Bool)) (/=) (Just "(/=)"),
+          BoundSymbol (Ref.TypeRep @(Children -> Children -> Bool)) (>=) (Just "(>=)"),
+          BoundSymbol (Ref.TypeRep @(Housing -> Housing -> Bool)) (>) (Just "(>)"),
+          BoundSymbol (Ref.TypeRep @(Housing -> Housing -> Bool)) (==) (Just "(==)"),
+          BoundSymbol (Ref.TypeRep @(Housing -> Housing -> Bool)) (/=) (Just "(/=)"),
+          BoundSymbol (Ref.TypeRep @(Housing -> Housing -> Bool)) (>=) (Just "(>=)"),
+          BoundSymbol (Ref.TypeRep @(Finance -> Finance -> Bool)) (>) (Just "(>)"),
+          BoundSymbol (Ref.TypeRep @(Finance -> Finance -> Bool)) (==) (Just "(==)"),
+          BoundSymbol (Ref.TypeRep @(Finance -> Finance -> Bool)) (/=) (Just "(/=)"),
+          BoundSymbol (Ref.TypeRep @(Finance -> Finance -> Bool)) (>=) (Just "(>=)"),
+          BoundSymbol (Ref.TypeRep @(Social -> Social -> Bool)) (>) (Just "(>)"),
+          BoundSymbol (Ref.TypeRep @(Social -> Social -> Bool)) (==) (Just "(==)"),
+          BoundSymbol (Ref.TypeRep @(Social -> Social -> Bool)) (/=) (Just "(/=)"),
+          BoundSymbol (Ref.TypeRep @(Social -> Social -> Bool)) (>=) (Just "(>=)"),
+          BoundSymbol (Ref.TypeRep @(Health -> Health -> Bool)) (>) (Just "(>)"),
+          BoundSymbol (Ref.TypeRep @(Health -> Health -> Bool)) (==) (Just "(==)"),
+          BoundSymbol (Ref.TypeRep @(Health -> Health -> Bool)) (/=) (Just "(/=)"),
+          BoundSymbol (Ref.TypeRep @(Health -> Health -> Bool)) (>=) (Just "(>=)"),
+          -- Eq Enum
+          -- Any Type
+          BoundSymbol (Ref.TypeRep @(Bool -> Int -> Int -> Int)) (if') (Just "if'"),
+          BoundSymbol (Ref.TypeRep @(Bool -> NurseryClass -> NurseryClass -> NurseryClass)) (if') (Just "if'"),
+          BoundSymbol (Ref.TypeRep @(Bool -> Parents -> Parents -> Parents)) (if') (Just "if'"),
+          BoundSymbol (Ref.TypeRep @(Bool -> HasNurs -> HasNurs -> HasNurs)) (if') (Just "if'"),
+          BoundSymbol (Ref.TypeRep @(Bool -> Form -> Form -> Form)) (if') (Just "if'"),
+          BoundSymbol (Ref.TypeRep @(Bool -> Children -> Children -> Children)) (if') (Just "if'"),
+          BoundSymbol (Ref.TypeRep @(Bool -> Housing -> Housing -> Housing)) (if') (Just "if'"),
+          BoundSymbol (Ref.TypeRep @(Bool -> Finance -> Finance -> Finance)) (if') (Just "if'"),
+          BoundSymbol (Ref.TypeRep @(Bool -> Social -> Social -> Social)) (if') (Just "if'"),
+          BoundSymbol (Ref.TypeRep @(Bool -> Health -> Health -> Health)) (if') (Just "if'")
+        ]
+
+
+lE :: LambdaEnviroment (Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass)
+lE =
+  LambdaEnviroment
+    { functions = operators,
+      constants =
+          [ ConstVal (Ref.TypeRep @(Bool)) (uniform True False),
+            ConstVal (Ref.TypeRep @(NurseryClass)) (enumUniform NotRecommend SpecPriority),
+            ConstVal (Ref.TypeRep @(Parents)) (enumUniform Usual GreatPret),
+            ConstVal (Ref.TypeRep @(HasNurs)) (enumUniform ProperNurs VeryCritNurs),
+            ConstVal (Ref.TypeRep @(Form)) (enumUniform CompleteFamilyForm FosterFamilyForm),
+            ConstVal (Ref.TypeRep @(Children)) (enumUniform OneChild MoreChilds),
+            ConstVal (Ref.TypeRep @(Housing)) (enumUniform ConvenientHousing CriticalHousing),
+            ConstVal (Ref.TypeRep @(Finance)) (enumUniform ConvenientFinance InconvFinance),
+            ConstVal (Ref.TypeRep @(Social)) (enumUniform NotProblematicSocial ProblematicSocial),
+            ConstVal (Ref.TypeRep @(Health)) (enumUniform NotRecommendHealth PriorityHealth)
+          ],
+      maxDepth = 150,
+      weights =
+        ExpressionWeights
+          { application = 2,
+            abstraction = 2,
+            variableReference = 300,
+            constant = 1,
+            functionBias = 100
+          },
+      mutationStrength = 10/150,
+      crossoverStrength = 15/150
+    }
+
+trainingFraction :: R
+trainingFraction = (2 / 3)
+
+lEE :: ExecutionEnviroment (Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass)
+lEE =
+  ExecutionEnviroment
+    { -- For now these need to define all available functions and types. Generic functions can be used.
+      fun = operators,
+      training = True,
+      trainingData = nurseryTrainingData,
+      testData = nurseryTrainingData
+    }
+
+shuffledLEE :: IO (ExecutionEnviroment (Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass))
+shuffledLEE = do
+  return
+    ExecutionEnviroment
+      { fun = operators,
+        training = True,
+        trainingData = nurseryTrainingData,
+        testData = nurseryTrainingData
+      }

lambda/src/Main.hs

@@ -1,15 +1,15 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
 import Options.Applicative
 import Pipes
-import Pretty
 import Protolude hiding (for)
 import System.IO
--- import Szenario212Pun
--- import Szenario191
-import IrisDataset
+-- import LambdaDatasets.IrisDataset
+import LambdaDatasets.NurseryDataset
+-- import LambdaDatasets.GermanDataset
 import Debug.Trace as DB
 import qualified Data.Map.Strict as Map
 
@@ -26,7 +26,7 @@ options =
       ( long "iterations"
           <> short 'i'
           <> metavar "N"
-          <> value 500
+          <> value 1
           <> help "Number of iterations"
       )
     <*> option
@@ -51,18 +51,25 @@ main :: IO ()
 main =
   execParser optionsWithHelp >>= \opts -> do
     hSetBuffering stdout NoBuffering
-    let env = irisLE
-    let selType = Tournament 3
-    let run' = run irisLEE env selType 40 (5 / 100) (populationSize opts) (steps (iterations opts))
-    pop' <- runEffect (for run' logCsv)
-    irisLEE' <- calc irisLEE  pop'
-    let (res, _) = bests irisLEE' 5 pop'
-    let irisLEE' = irisLEE {training = False}
-    irisLEE' <- calc irisLEE' res
-    mapM_ (format irisLEE') res
+    lEE <- shuffledLEE
+    let cfg = GaRunConfig {
+      enviroment = lE,
+      initialEvaluator = lEE,
+      selectionType = Tournament 3,
+      termination = (steps (iterations opts)),
+      poulationSize = (populationSize opts),
+      nParents = 120,
+      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 irisL s = do
-      let f = fitness' irisL s
-      putErrText $ show f <> "\n" <> pretty s
+    format l s = do
+      let f = fitness' l s
+      putErrText $ show f <> "\n" <> output (lE) s
     logCsv = putText . csv
     csv (t, f) = show t <> " " <> show f

lib/GA.hs

@@ -6,7 +6,11 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE NoImplicitPrelude #-}
-
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 -- |
 -- Module      : GA
 -- Description : Abstract genetic algorithm
@@ -20,7 +24,7 @@
 -- In order to use it for a certain problem, basically, you have to make your
 -- solution type an instance of 'Individual' and then simply call the 'run'
 -- function.
-module GA (Environment, new, population, mutate, crossover1, crossover, nX, Fitness, getR, Evaluator, fitness,fitness', calc, Individual, GA.run, Tournament (..), N, R, Population, steps, bests, runTests) where
+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 ((<|))
@@ -47,7 +51,9 @@ 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 where
+class (Individual i) => Environment i e | e -> i, i -> e where
+  output :: e -> i -> Text
+
   -- |
   --  Generates a completely random individual.
   new :: e -> RVar i
@@ -84,7 +90,7 @@ class (Pretty e, Individual i) => Environment i e | e -> i where
 -- |
 --  An Evaluator that Individuals of type i can be evaluated by
 --  It stores all information required to evaluate an individuals fitness
-class (Individual i, Fitness r) => Evaluator i e r | i -> e r where
+class (Individual i, Fitness r) => Evaluator i e r | e -> i r where
   -- |
   --  An individual's fitness. Higher values are considered “better”.
   --
@@ -93,14 +99,19 @@ class (Individual i, Fitness r) => Evaluator i e r | i -> e r where
   fitness :: e -> i -> R
   fitness env i = getR ( fitness' env i)
 
+  -- |
+  --  An more complete fitness object, used to include more info to the output of the current fitness.
+  --  You can e.g. track individual size with this.
   fitness' :: e -> i -> r
 
-  -- TODO kinda hacky?!?
+  -- |
+  -- here, fitness values for the next generation can be calculated at once, and just once, using any monadic action, if necessary.
+  -- It is guaranteed that the e passed to fitness is the result of a calc function, where the individual was part of the Population passed.
+  -- It may be smart to reuse known results between invocations.
   calc :: e -> Population i -> IO e
-  calc eval _ = do
-    return eval
+  calc eval _ = return eval
 
-class (Pretty i, Ord i) => Individual i
+class (Ord i) => Individual i
 
 class (Show i) => Fitness i where
   getR :: i -> R
@@ -206,21 +217,25 @@ selectBest eval pElite pop nPop = do
         then return elitists
         else return $ elitists <> (fst $ bests eval (nPop - length elitists) (NE.fromList rest))
 
-run ::
-  (Individual i, Evaluator i eval r, Environment i env, SelectionType s) =>
-  eval ->
-  env ->
-  -- | Mechanism for selecting parents
-  s ->
-  -- | Number of parents @nParents@ for creating @nParents@ children
-  N ->
-  -- | Elitism ratio @pElite@
-  R ->
-  -- | Population size
-  N ->
-  Termination i ->
-  Producer (Int, r) IO (Population i)
-run eval env selectionType nParents pElite nPop term = do
+
+-- 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)
@@ -228,12 +243,17 @@ run eval env selectionType nParents pElite nPop term = do
   return res
   where
     runIter eval count pop smpl = (
-      if term pop count
+      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 selectionType nParents 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
@@ -305,18 +325,18 @@ 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)
+newtype IntTestEnviroment = IntTestEnviroment ((Integer, Integer), Integer, N) deriving (Eq, Show) -- 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
+  output _ i = "Found int: " <> show i
+
   new (IntTestEnviroment ((from, to), _, _)) = uniform from to
 
   nX (IntTestEnviroment ((_, _), _, n)) = n

lib/LambdaCalculus.hs

@@ -9,7 +9,7 @@
 
 module LambdaCalculus where
 
-import Data.List (foldr1, last, nub, intersect, (!!), (\\))
+import Data.List (foldr1, intersect, last, nub, (!!), (\\))
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import Data.Maybe
@@ -17,14 +17,15 @@ 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 Debug.Trace as DB
 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,
@@ -73,7 +74,6 @@ exampleLE =
 
 type BoundVars = [TypeRep]
 
-
 -- we need a dynamic typ with a concept of equality here, should we want to interpret the result, instead of compiling it...
 type ConVal = Text
 
@@ -96,7 +96,6 @@ 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
@@ -179,7 +178,7 @@ genLambdaSchlucker env@(LambdaEnviroment functions constants _ _ weights) depthL
   let args = typeRepArgs target
   let lambaType = fromJust (head args)
   let toFind = last args
-  typeRequester <- genTypeRequester env depthLeft toFind (boundVar ++ [lambaType])
+  typeRequester <- genTypeRequester env (depthLeft + 1) toFind (boundVar ++ [lambaType])
   return (LambdaSchlucker typeRequester (boundVar ++ [lambaType]))
 
 genLambdaConst :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
@@ -234,6 +233,13 @@ instance Environment TypeRequester LambdaEnviroment where
     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
@@ -245,10 +251,14 @@ instance Environment TypeRequester LambdaEnviroment where
   crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do
     let trCount = countTrsR tr1
     selectedIndex1 <- uniform 1 trCount
-    let (depthAt, selectedTr1@(TR _ _ bound1)) = depthLeftAndTypeAtR tr1 selectedIndex1 maxDepth
-    let indexes = findIndicesWhere tr2 (isCompatibleTr selectedTr1) 0
-    if length indexes == 0 then return Nothing else (do
-      (selectedTr2@(TR _ _ bound2),selectedIndex2) <- randomElement indexes
+    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
@@ -256,78 +266,86 @@ instance Environment TypeRequester LambdaEnviroment where
             return $ Just (child1, child2)
         )
 
-
 -- helper
-adaptBoundVars:: TypeRequester -> BoundVars -> RVar TypeRequester
+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 :: 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 :: 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
+  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
+  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
+  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
+  where
+    convertTrf tr = convertTr tr bvOld bvNew mapper
 convertLe le@(Constan _) _ _ _ = le
 
-
-generateConversionIndexMap:: BoundVars -> BoundVars -> RVar (Map TypeRep (Int -> Int))
+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)
+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)
+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 :: Int -> Int -> RVar [Int]
 genPermutation i j = replicateM (i - j) (uniform 0 j)
 
-isCompatibleTr:: TypeRequester -> TypeRequester -> Bool
-isCompatibleTr tr1@(TR trep1 _ bound1) tr2@(TR trep2 _ bound2) | trep1 == trep2 = allUsedBound (usedVars bound1 tr1) bound2 && allUsedBound (usedVars bound2 tr2) bound1
+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 :: BoundVars -> BoundVars -> Bool
 boundsConvertable bv1 bv2 = length (nub bv2) == length (nub bv1) && length (intersect (nub bv1) bv2) == length (nub bv1)
 
-
-findIndicesWhere:: TypeRequester -> (TypeRequester -> Bool) -> Int -> [(TypeRequester, Int)]
-findIndicesWhere tr@(TR t lE _) filte indx = case lE of
-                           Just le -> if filte tr then (tr, indx+1):(findIndicesWhere' (asList le) filte (indx+1)) else (findIndicesWhere' (asList le) filte (indx+1))
+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 -> Bool) -> Int -> [(TypeRequester, Int)]
-findIndicesWhere' [] _ _ = []
-findIndicesWhere' [tr] f indx = (findIndicesWhere tr f indx)
-findIndicesWhere' (tr:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr))
+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
@@ -351,6 +369,7 @@ depthLeftAndTypeAtR (TR _ (Just le) _) indexLeft depthLeft = depthLeftAndTypeAt
 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)
@@ -365,17 +384,6 @@ countTrsR tr@(TR t lE _) = case lE of
 countTrs :: LambdaExpression -> Int
 countTrs le = sum (map countTrsR (asList le))
 
-repeatedly :: (a -> Maybe a) -> a -> [a]
-repeatedly f x = case f x of
-  Nothing -> []
-  Just y -> y : repeatedly f y
-
-count :: (Eq a) => [a] -> a -> Int
-count [] find = 0
-count ys find = length xs
-  where
-    xs = [xs | xs <- ys, xs == find]
-
 -- Test Stuff
 
 testConstInt :: TypeRequester
@@ -535,34 +543,3 @@ eToLambdaExpressionShort (Constan (valS)) = valS
 
 res :: Int -> ResClass
 res = ((\lInt0 -> ((iteClass ((eqInt ((lInt0) :: (Int)) ((1) :: (Int))) :: (Bool)) ((Class1) :: (ResClass)) ((iteClass ((eqInt ((lInt0) :: (Int)) ((2) :: (Int))) :: (Bool)) ((Class2) :: (ResClass)) ((iteClass ((eqInt ((lInt0) :: (Int)) ((3) :: (Int))) :: (Bool)) ((Class3) :: (ResClass)) ((Class3) :: (ResClass))) :: (ResClass))) :: (ResClass))) :: (ResClass))) :: (Int -> ResClass))
-
-
-meanOfAccuricyPerClass :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
-meanOfAccuricyPerClass results = mean $ map (accuracyInClass results) [minBound .. maxBound]
-
-geomeanOfAccuricyPerClass :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
-geomeanOfAccuricyPerClass results = geomean $ map (accuracyInClass results) [minBound .. maxBound]
-
-geomeanOfDistributionAccuracy :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
-geomeanOfDistributionAccuracy results = geomean $ map (distributionAccuracyForClass results) [minBound .. maxBound]
-
-distributionAccuracyForClass :: (Eq r) => [(r, r)] -> r -> R
-distributionAccuracyForClass results clas = (1 - (min 1 (fromIntegral (abs ((length (inResClass results clas)) - (length (inClass results clas)))) / fromIntegral (length (inClass results clas))))) * 100
-
-mean :: (Show f, Floating f) => [f] -> f
-mean values = (sum values) * (1 / (fromIntegral (length values)))
-
-geomean :: (Show f, Floating f) => [f] -> f
-geomean values = (product values) ** (1 / (fromIntegral (length values)))
-
-accuracyInClass :: (Eq r) => [(r, r)] -> r -> R
-accuracyInClass results clas = ((accuracy'(inResClass results clas)) * 100) / fromIntegral (length (inClass results clas))
-
-inClass :: (Eq r) => [(r, r)] -> r -> [(r, r)]
-inClass results clas = (filter ((clas ==) . fst) results)
-
-inResClass :: (Eq r) => [(r, r)] -> r -> [(r, r)]
-inResClass results clas = (filter ((clas ==) . snd) results)
-
-accuracy' :: (Eq r) => [(r, r)] -> R
-accuracy' results = fromIntegral $ length (filter (\(target, res) -> (res == target)) results)

lib/LambdaCalculusV2.hs

@@ -0,0 +1,578 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeAbstractions #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module LambdaCalculusV2 where
+
+import Data.Dynamic
+import Data.Kind
+import qualified Data.Set as Set
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map.Strict as Map
+import Data.Random
+import Data.Typeable
+import Debug.Trace as DB
+import qualified Data.Text as T
+import GA
+import Protolude
+import Protolude.Error
+import Protolude.Partial
+import qualified Type.Reflection as Ref
+import Utils
+
+data BoundSymbol where
+  BoundSymbol :: (Typeable a) => Ref.TypeRep a -> a -> Maybe Text -> BoundSymbol
+
+type Bindings = Map.Map (Ref.SomeTypeRep) Int
+
+data SomeSimplyTypedLambdaExpression where
+  SomeSimplyTypedLambdaExpression :: (Typeable a) => SimplyTypedLambdaExpression a -> SomeSimplyTypedLambdaExpression
+
+-- We specify a and use GADTs to allow Haskell to guarantee full type safety over these expressions!
+-- This gurantees us that a SimplyTypedLambdaExpression a describes a lambda expression of type a!
+data SimplyTypedLambdaExpression t where
+  Application :: (Typeable a, Typeable b) => SimplyTypedLambdaExpression (a -> b) -> SimplyTypedLambdaExpression a -> SimplyTypedLambdaExpression b -- e = e1 e2
+  Abstraction :: (Typeable (a -> b), Typeable b) => Ref.TypeRep a -> SimplyTypedLambdaExpression (b) -> SimplyTypedLambdaExpression (a -> b) -- e = λx:a. e
+  VariableReference :: (Typeable a) => Ref.TypeRep a -> Int -> SimplyTypedLambdaExpression a -- e = x this Includes predefined function use!
+  Constant :: (Typeable a, Ord a, Hashable a, Show a) => a -> SimplyTypedLambdaExpression a -- e = c
+
+instance Eq (SimplyTypedLambdaExpression t) where
+  e1 == e2 = compare e1 e2 == EQ
+
+instance Ord (SimplyTypedLambdaExpression t) where
+  compare (Application (stleAtoB1 :: SimplyTypedLambdaExpression (a1 -> t)) (stleA1 :: SimplyTypedLambdaExpression a1)) (Application (stleAtoB2 :: SimplyTypedLambdaExpression (a2 -> t)) (stleA2 :: SimplyTypedLambdaExpression a2)) = case eqT @a1 @a2 of
+    Just Refl -> (compare stleAtoB1 stleAtoB2) `thenCmp` (compare stleA1 stleA2)
+    _ -> compare (Ref.SomeTypeRep (Ref.TypeRep @a1)) (Ref.SomeTypeRep (Ref.TypeRep @a2))
+  compare (Abstraction rep1 stle1) (Abstraction rep2 stle2) = (compare rep1 rep2) `thenCmp` (compare stle1 stle2)
+  compare (VariableReference repA inx1) (VariableReference repB inx2) = (compare repA repB) `thenCmp` (compare inx1 inx2)
+  compare (Constant res1) (Constant res2) = compare res1 res2
+  compare (Application _ _) _ = LT
+  compare _ (Application _ _) = GT
+  compare (Abstraction _ _) _ = LT
+  compare _ (Abstraction _ _) = GT
+  compare (VariableReference _ _) _ = LT
+  compare _ (VariableReference _ _) = GT
+
+instance Hashable (SimplyTypedLambdaExpression t) where
+  hashWithSalt salt (Application stleAtoB stleA) = salt `hashWithSalt` (1 :: Int) `hashWithSalt` stleAtoB `hashWithSalt` stleA
+  hashWithSalt salt (Abstraction rep stle) = salt `hashWithSalt` (2 :: Int) `hashWithSalt` rep `hashWithSalt` stle
+  hashWithSalt salt (VariableReference rep inx) = salt `hashWithSalt` (3 :: Int) `hashWithSalt` rep `hashWithSalt` inx
+  hashWithSalt salt (Constant res) = salt `hashWithSalt` (4 :: Int) `hashWithSalt` res
+
+thenCmp :: Ordering -> Ordering -> Ordering
+thenCmp EQ o2 = o2
+thenCmp o1 _ = o1
+
+data ConstVal where
+  ConstVal :: (Typeable a, Ord a, Hashable a, Show a) => Ref.TypeRep a -> RVar a -> ConstVal
+
+data ExpressionWeights = ExpressionWeights
+  { application :: Int,
+    abstraction :: Int,
+    variableReference :: Int,
+    constant :: Int,
+    -- chance in percent an Application will (try to) work towards something from the boundVars becoming usable. I recommend values over 90.
+    functionBias :: Int
+  }
+
+data LambdaEnviroment a = LambdaEnviroment
+  { functions :: [BoundSymbol],
+    constants :: [ConstVal],
+    maxDepth :: Int,
+    weights :: ExpressionWeights,
+    --  likelyhood of an sub-expression to be mutated
+    mutationStrength :: Float,
+    --  likelyhood of an crossover attempt at a sub-expression
+    crossoverStrength :: Float
+  }
+
+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
+
+data Dataset t where
+  Input :: (Typeable a, Typeable b) => [a] -> Dataset b -> Dataset (a -> b)
+  Result :: (Typeable a, Eq a, Enum a, Bounded a) => [a] -> Dataset a
+
+data ExecutionEnviroment e = ExecutionEnviroment {
+    fun :: [BoundSymbol],
+    training :: Bool,
+    trainingData :: Dataset e,
+    testData :: Dataset e
+  }
+
+data ResultList where
+  Res :: (Typeable a, Eq a, Enum a, Bounded a) => [(a,a)] -> ResultList
+
+instance Typeable a => Evaluator (SimplyTypedLambdaExpression a) (ExecutionEnviroment a) FittnesRes where
+  fitness' ee@(ExecutionEnviroment {fun}) e = evalResult ee e (eval fun e)
+
+evalResult :: ExecutionEnviroment a -> SimplyTypedLambdaExpression a -> a -> FittnesRes
+evalResult (ExecutionEnviroment {training, trainingData, testData}) tr result = FittnesRes
+        { total = (\(Res r) -> meanOfDistributionAccuracy r) res,
+          fitnessTotal = fitness',
+          fitnessMean = (\(Res r) -> meanOfAccuricyPerClass r) res ,
+          fitnessGeoMean = (\(Res r) -> meanOfDistributionAccuracy r) res,
+          accuracy = acc,
+          biasSize = biasSmall,
+          totalSize = expSize tr
+        }
+    where
+    dataS = (if training then trainingData else testData)
+    res = apply result dataS
+    acc = (\(Res r) -> (foldr (\(ts) s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 r) / fromIntegral (length r)) res
+    biasSmall = exp ((-(fromIntegral (expSize tr))) / 1000) -- 0 (schlecht) bis 1 (gut)
+    fitness' = (\(Res r) -> meanOfAccuricyPerClass r) res
+    score = fitness' + (biasSmall - 1)
+
+apply :: a -> Dataset a -> ResultList
+apply fun (Input b c) = applyL (map fun b) c
+apply val (Result b) = Res (zip b (repeat val))
+
+applyL :: [a] -> Dataset a -> ResultList
+applyL fun (Input b c) = applyL (zipWith (\a b -> a b) fun b) c
+applyL val (Result b) = Res (zip b val)
+
+
+
+hasSymbolOfType :: forall (a :: Type). [BoundSymbol] -> Ref.TypeRep a -> Bool
+hasSymbolOfType bound tr = length ((getSymbolsOfType bound tr) :: [a]) /= 0
+
+getSymbolsOfType :: forall a. [BoundSymbol] -> Ref.TypeRep a -> [a]
+getSymbolsOfType bound tr = mapMaybe (getIfType tr) bound
+
+getBoundSymbolsOfType :: forall a. [BoundSymbol] -> Ref.TypeRep a -> [BoundSymbol]
+getBoundSymbolsOfType bound tr = mapMaybe (getSymbolIfType tr) bound
+
+getSymbolIfType :: forall a. Ref.TypeRep a -> BoundSymbol -> Maybe BoundSymbol
+getSymbolIfType rep b@(BoundSymbol t _ _)
+  | Just Ref.HRefl <- t `Ref.eqTypeRep` rep = Just b
+  | otherwise = Nothing
+
+getIfType :: forall a. Ref.TypeRep a -> BoundSymbol -> Maybe a
+getIfType rep (BoundSymbol t val _)
+  | Just Ref.HRefl <- t `Ref.eqTypeRep` rep = Just val
+  | otherwise = Nothing
+
+startingBindings :: [BoundSymbol] -> Bindings
+startingBindings functions = (foldr (\(BoundSymbol tr _ _) map -> Map.insertWith (+) (Ref.SomeTypeRep tr) 1 map) Map.empty functions)
+
+showSanifid :: (Show a) => a -> Text
+showSanifid var = T.replace " -> " "To" (show var)
+
+toDotE :: LambdaEnviroment a -> Text
+toDotE (LambdaEnviroment {functions}) = foldr (<>) "" (map (\(BoundSymbol tr _ t, inx) -> "\"" <> (showSanifid tr) <> show inx <> "\" [style = invis label = " <> fromJust t <>"\"]\n") (concatMap (\(Ref.SomeTypeRep k,v) -> zip (getBoundSymbolsOfType functions k)[0 .. (v-1)]) (Map.toList (startingBindings functions))))
+
+toDotI :: SimplyTypedLambdaExpression e -> Int -> Text
+toDotI (Application e1 e2) inx = "\"app" <> show inx <> "\" -- "  <> toDotI e1 (inx + 1) <> "\n" <> "\"app" <> show inx <> "\" -- "  <> toDotI e2 (inx + 1 + expSize e1)
+toDotI (Abstraction _ e) inx = "\"abs" <> show inx <> "\" -- "  <> toDotI e (inx + 1)
+toDotI (VariableReference tr i) _ = "\"" <> (showSanifid tr) <> show i <> "\""
+toDotI (Constant c) _ = "\"" <> show c <> "\""
+
+instance Eq SomeSimplyTypedLambdaExpression where
+  e1 == e2 = compare e1 e2 == EQ
+
+instance Ord SomeSimplyTypedLambdaExpression where
+  compare (SomeSimplyTypedLambdaExpression (e1 :: SimplyTypedLambdaExpression a)) (SomeSimplyTypedLambdaExpression (e2 :: SimplyTypedLambdaExpression b))
+    | Just Refl <- eqT @a @b = compare e1 e2
+    | otherwise = compare (Ref.SomeTypeRep (Ref.TypeRep @a)) (Ref.SomeTypeRep (Ref.TypeRep @b))
+
+instance Typeable a => Individual (SimplyTypedLambdaExpression a)
+
+instance Typeable a => Environment (SimplyTypedLambdaExpression a) (LambdaEnviroment a) where
+  output env  i = toDotE env <> toDotI i 0
+
+  nX _ = 3
+
+  new env = DB.trace "new !" ((generateFromEnv env) :: RVar (SimplyTypedLambdaExpression a))
+
+  mutate env le = (mutateUnwrapped env le)
+
+  crossover1 env le  le2 = crossoverUnwrapper env le le2
+
+crossoverUnwrapper :: (Typeable a) => LambdaEnviroment a -> SimplyTypedLambdaExpression a -> SimplyTypedLambdaExpression a -> RVar (Maybe (SimplyTypedLambdaExpression a, SimplyTypedLambdaExpression a))
+crossoverUnwrapper env@(LambdaEnviroment {maxDepth, functions}) le1 le2 =
+      ( do
+          (tree1, tree2) <- crossedover le1 le2 env maxDepth (startingBindings functions)
+          return $ if (tree2 == le2) then Nothing else Just (tree1, tree2)
+      )
+
+crossedover :: forall a e. (Typeable a,Typeable e) => SimplyTypedLambdaExpression a -> SimplyTypedLambdaExpression e -> LambdaEnviroment e -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression a, SimplyTypedLambdaExpression e)
+crossedover le1 le2 env@(LambdaEnviroment {crossoverStrength, maxDepth, functions}) sizeLeft bound = do
+  roll <- uniform 0 1
+  let crossoverChild =
+        ( case le1 of
+            (Application e1 e2) ->
+              ( do
+                  (elm1, partner1) <- crossedover e1 le2 env ((sizeLeft - 1) - expSize e2) bound
+                  (elm2, partner2) <- crossedover e2 le2 env ((sizeLeft - 1) - expSize e1) bound
+                  leftMutated <- uniform False True
+                  let mutateLeft = if partner1 == le2 then False else (if partner2 == le2 then False else leftMutated)
+                  return $ if mutateLeft then (Application elm1 e2, partner1) else (Application e1 elm2, partner2)
+              )
+            (Abstraction tr e) ->
+              ( do
+                  (elm2, partner2) <- crossedover e le2 env (sizeLeft - 1) (Map.insertWith (+) (Ref.SomeTypeRep tr) 1 bound)
+                  return $ (Abstraction tr elm2, partner2)
+              )
+            _ -> return (le1, le2)
+        )
+  if (roll < crossoverStrength)
+    then
+      ( do
+          maybeSwapped <- trySwapSubtree le1 sizeLeft bound le2 maxDepth (startingBindings functions)
+          case maybeSwapped of
+            Just (ler1, ler2) -> return (ler1, ler2)
+            _ -> crossoverChild
+      )
+    else crossoverChild
+
+trySwapSubtree :: forall a e.(Typeable a,Typeable e) =>  SimplyTypedLambdaExpression a -> Int -> Bindings -> SimplyTypedLambdaExpression e -> Int -> Bindings -> RVar (Maybe (SimplyTypedLambdaExpression a, SimplyTypedLambdaExpression e))
+trySwapSubtree le1 sizeLeft bound le2 sizeLeft2 bound2 = do
+    let possible = possibleSwapSubtrees le1 sizeLeft bound le2 sizeLeft2 bound2
+    case possible of
+         [] -> return Nothing
+         ne -> Just <$> randomElement ne
+
+
+possibleSwapSubtrees :: forall a e.(Typeable a,Typeable e) => SimplyTypedLambdaExpression a -> Int -> Bindings -> SimplyTypedLambdaExpression e -> Int -> Bindings -> [(SimplyTypedLambdaExpression a, SimplyTypedLambdaExpression e)]
+possibleSwapSubtrees le1 sizeLeft bound le2 sizeLeft2 bound2
+  | Just Refl <- eqT @a @e =  if compatibleSubtree sizeLeft2 bound2 le1 && compatibleSubtree sizeLeft bound le2 then (adaptSubtree bound2 le1, adaptSubtree bound le2) : continue else continue
+  | otherwise = continue
+  where
+    continue = (case le2 of
+          Application e1 e2 -> (map (\(li1,li2) -> (li1, (Application e1 li2))) (possibleSwapSubtrees le1 sizeLeft bound e2 (sizeLeft2 - 1 - expSize e1) bound2) ) ++ (map (\(li1,li2) -> (li1, (Application li2 e2))) (possibleSwapSubtrees le1 sizeLeft bound e1 (sizeLeft2 - 1 - expSize e2) bound2) )
+          Abstraction t e -> (map (\(li1,li2) -> (li1, (Abstraction t li2))) (possibleSwapSubtrees le1 sizeLeft bound e (sizeLeft2 - 1) (addToBindings t bound2)))
+          _ -> [])
+
+addToBindings ::Ref.TypeRep a -> Bindings -> Bindings
+addToBindings t bound =  (Map.insertWith (+) (Ref.SomeTypeRep t) 1 bound)
+
+adaptSubtree :: Bindings -> SimplyTypedLambdaExpression e -> SimplyTypedLambdaExpression e
+adaptSubtree bound (Application e1 e2) = (Application (adaptSubtree bound e1) (adaptSubtree bound e2))
+adaptSubtree bound (Abstraction t e) = (Abstraction t (adaptSubtree (addToBindings t bound) e))
+adaptSubtree bound (VariableReference tr idx) =  (VariableReference tr (mod idx ( bound Map.! (Ref.SomeTypeRep tr))))
+adaptSubtree _ e = e
+
+compatibleSubtree :: Int -> Bindings -> SimplyTypedLambdaExpression e -> Bool
+compatibleSubtree sizeLeft bound subtree =  bound `bindingContains` (bindingReq subtree) && sizeLeft > (expSize subtree)
+
+expSize :: SimplyTypedLambdaExpression e -> Int
+expSize (Application e1 e2) = expSize e1 + expSize e2 + 1
+expSize (Abstraction _ e) = expSize e + 1
+expSize _ = 1
+
+bindingReq :: SimplyTypedLambdaExpression e -> Bindings
+bindingReq (Application e1 e2) = Map.unionWith (max) (bindingReq e1) (bindingReq e2)
+bindingReq (Abstraction tr e) = rmFromBindings tr (bindingReq e)
+bindingReq (VariableReference tr idx) = Map.singleton (Ref.SomeTypeRep tr) 1
+bindingReq (Constant _) = Map.empty
+
+rmFromBindings ::Ref.TypeRep a -> Bindings -> Bindings
+rmFromBindings t bound =  (Map.insertWith (\i1 i2 -> max 0 (i1 + i2)) (Ref.SomeTypeRep t) (- 1) bound)
+
+bindingContains :: Bindings -> Bindings -> Bool
+bindingContains superset subset = all (\(key,val) -> (fromMaybe 0 (Map.lookup key superset)) >= val ) (Map.toList subset)
+
+mutateUnwrapped :: (Typeable r) => LambdaEnviroment r -> SimplyTypedLambdaExpression r -> RVar (SimplyTypedLambdaExpression r)
+mutateUnwrapped env@(LambdaEnviroment {maxDepth, functions}) stle = mutated stle env maxDepth (startingBindings functions)
+
+mutated :: forall r a. (Typeable r) => SimplyTypedLambdaExpression r -> LambdaEnviroment a -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
+mutated (Application e1 e2) env@(LambdaEnviroment {constants, mutationStrength}) sizeLeft bound = do
+  roll <- uniform 0 1
+  if (roll < mutationStrength)
+    then generate env (Ref.TypeRep @r) constants sizeLeft bound
+    else do
+      sizeDistribution <- uniform 0 (sizeLeft - 1)
+      elm1 <- mutated e1 env sizeDistribution bound
+      elm2 <- mutated e2 env ((sizeLeft - 1) - sizeDistribution) bound
+      return $ Application elm1 elm2
+mutated (Abstraction tr e) env@(LambdaEnviroment {constants, mutationStrength}) sizeLeft bound = do
+  roll <- uniform 0 1
+  if (roll < mutationStrength)
+    then generate env (Ref.TypeRep @r) constants sizeLeft bound
+    else do
+      elm2 <- mutated e env (sizeLeft - 1) (Map.insertWith (+) (Ref.SomeTypeRep tr) 1 bound)
+      return $ Abstraction tr elm2
+mutated stle env@(LambdaEnviroment {constants, mutationStrength}) sizeLeft bound = do
+  roll <- uniform 0 1
+  if (roll < mutationStrength) then generate env (Ref.TypeRep @r) constants sizeLeft bound else return stle
+
+
+test :: SimplyTypedLambdaExpression (Bool -> Int -> Int -> Int)
+test = Abstraction (Ref.typeRep @(Bool)) (Abstraction (Ref.typeRep @(Int)) (Abstraction (Ref.typeRep @(Int)) (Constant 5)))
+
+generateFromEnv :: forall r. (Typeable r) => LambdaEnviroment r -> RVar (SimplyTypedLambdaExpression r)
+generateFromEnv env@(LambdaEnviroment {functions, constants, maxDepth}) = generate env (Ref.TypeRep @r) constants maxDepth (foldr (\(BoundSymbol tr _ _) map -> Map.insertWith (+) (Ref.SomeTypeRep tr) 1 map) Map.empty functions)
+
+generate :: LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
+generate env tr@(Ref.Fun (Ref.TypeRep @a) (Ref.TypeRep @b)) constantTypes sizeLeft bound
+  | (sizeLeft > 0) && (Map.member (Ref.SomeTypeRep tr) bound) =  do
+      let weight = weights env
+      let options = [(application weight, genApplication env tr constantTypes sizeLeft bound), (abstraction weight, genAbstraction env tr constantTypes sizeLeft bound), (variableReference weight, genVariableReference env tr constantTypes sizeLeft bound)]
+      expres <- selectWeighted options
+      res <- expres
+      return res
+  | (sizeLeft > 0) =   do
+      let weight = weights env
+      let options = [(application weight + round (1000 * closestFractionMatch tr bndK), genApplication env tr constantTypes sizeLeft bound), (abstraction weight, genAbstraction env tr constantTypes sizeLeft bound)]
+      expres <- selectWeighted options
+      res <- expres
+      return res
+  -- Application can crate a fitting type in a smaller expression. e.g. if':: Bool -> (Int-> Int -> Bool) -> (Int-> Int -> Bool) -> (Int-> Int -> Bool) and target type (Int-> Int -> Bool) -> (Int-> Int -> Bool) -> (Int-> Int -> Bool) can be finished in one Application (if' True::(Int-> Int -> Bool) -> (Int-> Int -> Bool) -> (Int-> Int -> Bool)) and one Var or constant, but resoving it purely with Abstractions would require 5 abstractions and one constant or var
+--  | (any (< typeDepth tr) (mapMaybe (sizeMising tr) bndK)) =   do
+--      let weight = weights env
+--      let options = [(application weight + (typeDepth tr - (minimum (mapMaybe (sizeMising tr) bndK))), genApplication env tr constantTypes sizeLeft bound), (abstraction weight, genAbstraction env tr constantTypes sizeLeft bound)]
+--      expres <- selectWeighted options
+--      res <- expres
+--      return res
+  | (Map.member (Ref.SomeTypeRep tr) bound) =   do
+      let weight = weights env
+      let options = [(abstraction weight, genAbstraction env tr constantTypes sizeLeft bound), (variableReference weight, genVariableReference env tr constantTypes sizeLeft bound)]
+      expres <- selectWeighted options
+      res <- expres
+      return res
+  | otherwise =   do
+      res <- genAbstraction env tr constantTypes sizeLeft bound
+      return res
+  where
+    bndK = Map.keys bound
+generate env tr constantTypes sizeLeft bound
+  | (sizeLeft > 0) && (Map.member (Ref.SomeTypeRep tr) bound) =    do
+      let weight = weights env
+      let options = [(application weight, genApplication env tr constantTypes sizeLeft bound), (constant weight, genConstant tr constantTypes sizeLeft bound), (variableReference weight, genVariableReference env tr constantTypes sizeLeft bound)]
+      expres <- selectWeighted options
+      res <- expres
+      return res
+  | (sizeLeft > 0) =    do
+      let weight = weights env
+      let options = [(application weight + round (1000 * closestFractionMatch tr bndK), genApplication env tr constantTypes sizeLeft bound), (constant weight, genConstant tr constantTypes sizeLeft bound)]
+      expres <- selectWeighted options
+      res <- expres
+      return res
+  | (Map.member (Ref.SomeTypeRep tr) bound) =  do
+      let weight = weights env
+      let options = [(constant weight, genConstant tr constantTypes sizeLeft bound), (variableReference weight, genVariableReference env tr constantTypes sizeLeft bound)]
+      expres <- selectWeighted options
+      res <- expres
+      return res
+  | otherwise =   do
+      res <- genConstant tr constantTypes sizeLeft bound
+      return res
+  where
+    bndK = Map.keys bound
+
+genVariableReference :: LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
+genVariableReference _ tr@(Ref.TypeRep) _ _ bound = do
+  typeIndex <- uniform 0 (((Map.!) bound (Ref.SomeTypeRep tr)) - 1)
+  return $ (VariableReference tr typeIndex)
+
+genConstant :: Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
+genConstant (Ref.TypeRep @a) constantTypes _ _ = do
+  val <- (constantGen constantTypes) :: RVar (SimplyTypedLambdaExpression a)
+  return $ val
+
+constantGen :: forall a. (Typeable a) => [ConstVal] -> RVar (SimplyTypedLambdaExpression a)
+constantGen ((ConstVal tr rVal) : rest)
+  | Just Ref.HRefl <- Ref.typeRep @a `Ref.eqTypeRep` tr = Constant <$> rVal
+  | otherwise = constantGen rest
+constantGen [] = error $ "unknown constant " <> show (Ref.typeRep @a)
+
+genAbstraction :: forall r a. LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
+genAbstraction env tr@(Ref.Fun trA@(Ref.TypeRep) trB@(Ref.TypeRep)) constantTypes sizeLeft bound
+  | Just Ref.HRefl <- Ref.typeRep @Type `Ref.eqTypeRep` Ref.typeRepKind trA,
+    Just Ref.HRefl <- Ref.typeRep @Type `Ref.eqTypeRep` Ref.typeRepKind trB = do
+      child <- generate env trB constantTypes (sizeLeft - 1) (Map.insertWith (+) (Ref.SomeTypeRep trA) 1 bound)
+      return $ Abstraction trA child
+genAbstraction _ tr _ _ _ = error $ "cannot generate Abstraction for " <> show tr
+
+-- generate: e:a = e1:b->a e2:b
+-- the by far most complex functions in this module! why?
+-- 1. we need to sensibly limit how insane we make b, favorably without excluding anything completely!
+-- 2. we need this function to heavily lean towards generating an b->a available in Bindings, so we are likely to use any predefined functions... at all
+genApplication :: forall r c a. LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
+genApplication env@(LambdaEnviroment {weights}) tr constantTypes sizeLeft bound
+  | (sizeLeft <= 0) = genApplicationClosestToCompletion env tr constantTypes bound
+  | otherwise = do
+      i <- uniform 0 100
+      ( if i < (functionBias weights) && any (1 >) (mapMaybe (matchedFractionS tr) (Map.keys bound))
+          then (genApplicationTowardsBound (maximum (filter (1 >) (mapMaybe (matchedFractionS tr) (Map.keys bound)))) env tr constantTypes sizeLeft bound)
+          else (genRandomApplication env tr constantTypes sizeLeft bound)
+        )
+
+closestFractionMatch :: Ref.TypeRep r -> [Ref.SomeTypeRep] -> Float
+closestFractionMatch tr trs | any (1 >) (mapMaybe (matchedFractionS tr) (trs)) = (maximum (filter (1 >) (mapMaybe (matchedFractionS tr) (trs))))
+                            | otherwise = 0
+
+genRandomApplication :: forall a r c. LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
+genRandomApplication env tr constantTypes sizeLeft bound = do
+  t1 <- randomType constantTypes
+  genApplicationWithTypeOfS t1 env tr constantTypes sizeLeft bound
+
+randomType :: [ConstVal] -> RVar Ref.SomeTypeRep
+randomType constantTypes = do
+  functon :: Int <- (uniform 0 100)
+  ret <-
+    if functon < 25
+      then
+        ( do
+            tr1 <- randomType constantTypes
+            tr2 <- randomType constantTypes
+            return (mkFunTy tr1 tr2)
+        )
+      else
+        ( do
+            (ConstVal _ (_ :: RVar t1)) <- randomElement constantTypes
+            return $ Ref.SomeTypeRep (Ref.TypeRep @t1)
+        )
+  return ret
+
+genApplicationClosestToCompletion :: forall r a. LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Bindings -> RVar (SimplyTypedLambdaExpression r)
+genApplicationClosestToCompletion env tr constantTypes bound = do
+  (ref) <- nextTypeFromClosestBound tr bound
+  genApplicationWithTypeOfS ref env tr constantTypes 0 bound
+
+nextTypeFromClosestBound :: Ref.TypeRep r -> Bindings -> RVar Ref.SomeTypeRep
+nextTypeFromClosestBound trB bound = randomElement ((getMinimasByMaybe (sizeMising trB) (filter (matchingTypesS trB) (Map.keys bound))))
+
+genApplicationTowardsBound :: forall r c a. Float -> LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
+genApplicationTowardsBound matchedFrac env tr constantTypes sizeLeft bound
+  | nextMatchedFrac > 0 = do
+      (f :: Float) <- uniform 0 1
+      bs <- randomElement (filter (\bs -> Just matchedFrac == matchedFractionS tr bs) (Map.keys bound))
+      if (f < matchedFrac + 1) then (genApplicationWithTypeOfS ((nextTypeS tr bs)) env tr constantTypes sizeLeft bound) else (genApplicationTowardsBound nextMatchedFrac env tr constantTypes sizeLeft bound)
+  | otherwise = do
+      bs <- randomElement (filter (\bs -> Just matchedFrac == matchedFractionS tr bs) (Map.keys bound))
+      genApplicationWithTypeOfS ((nextTypeS tr bs)) env tr constantTypes sizeLeft bound
+  where
+    nextMatchedFrac = (if (any (matchedFrac >) (mapMaybe (matchedFractionS tr) (Map.keys bound))) then (maximum (filter (matchedFrac >) (mapMaybe (matchedFractionS tr) (Map.keys bound)))) else 0) --todo nicer!
+
+-- how many Base types will need to be generated for bound to fit onto tr. This equals the size of the subtree that needs to be generated.
+sizeMising :: Ref.TypeRep r -> Ref.SomeTypeRep -> Maybe Int
+sizeMising tr (Ref.SomeTypeRep trbs)
+  | matchingTypes tr trbs = Just $ (typeDepth tr) - (typeDepth trbs)
+  | otherwise = Nothing
+
+matchedFractionS :: Ref.TypeRep r -> Ref.SomeTypeRep -> Maybe Float
+matchedFractionS tr (Ref.SomeTypeRep trbs) = matchedFraction tr trbs
+
+matchedFraction :: Ref.TypeRep r -> Ref.TypeRep a -> Maybe Float
+matchedFraction tr trbs
+  | matchingTypes tr trbs = Just $ fromIntegral (typeDepth trbs) / fromIntegral (typeDepth tr)
+  | otherwise = Nothing
+
+nextTypeS :: Ref.TypeRep r -> Ref.SomeTypeRep -> Ref.SomeTypeRep
+nextTypeS tr (Ref.SomeTypeRep trbs) = nextType tr trbs
+
+nextType :: Ref.TypeRep r -> Ref.TypeRep a -> Ref.SomeTypeRep
+nextType trR@(Ref.Fun (from) (to)) avail
+  | Just Ref.HRefl <- (to `Ref.eqTypeRep` avail),
+    Just Ref.HRefl <- Ref.typeRep @Type `Ref.eqTypeRep` Ref.typeRepKind from =
+      Ref.SomeTypeRep from
+  | otherwise = nextType to avail
+nextType tra trbs = error ("can't extract nextType from " <> show tra <> " and " <> show trbs)
+
+matchingTypesS :: Ref.TypeRep r -> Ref.SomeTypeRep -> Bool
+matchingTypesS tr (Ref.SomeTypeRep trbs) = matchingTypes tr trbs
+
+matchingTypes :: Ref.TypeRep a -> Ref.TypeRep b -> Bool
+matchingTypes tra trb | Ref.SomeTypeRep tra == Ref.SomeTypeRep trb = True
+matchingTypes (Ref.Fun _ (traRes :: Ref.TypeRep aRes)) trb = matchingTypes (traRes :: Ref.TypeRep aRes) trb
+matchingTypes _ _ = False
+
+typeSize :: Ref.TypeRep r -> Int
+typeSize (Ref.Fun _ trb) = 1 + (typeSize trb)
+typeSize _ = 1
+
+typeDepth :: Ref.TypeRep r -> Int
+typeDepth (Ref.Fun _ (trb :: Ref.TypeRep b)) = 1 + (typeDepth (trb :: Ref.TypeRep b))
+typeDepth _ = 1
+
+genApplicationWithTypeOfS :: forall r a. Ref.SomeTypeRep -> LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
+genApplicationWithTypeOfS (Ref.SomeTypeRep btr@(Ref.TypeRep))
+  | Just Ref.HRefl <- Ref.typeRep @Type `Ref.eqTypeRep` Ref.typeRepKind btr = genApplicationWithTypeOfB btr
+genApplicationWithTypeOfS (Ref.SomeTypeRep btr) = error $ "typeRepKind not Type: " <> show (Ref.typeRepKind btr)
+
+genApplicationWithTypeOfB :: forall r a (b :: Type). Ref.TypeRep b -> LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
+genApplicationWithTypeOfB trB@(Ref.TypeRep) env trR@(Ref.TypeRep) constantTypes sizeLeft bound = do
+  sizeDistribution <- uniform 0 (sizeLeft - 1)
+  right <- generate env trB constantTypes sizeDistribution bound
+  left <- generate env (Ref.Fun (Ref.TypeRep @b) trR) constantTypes ((sizeLeft - 1) - sizeDistribution) bound
+  return $ Application left right
+
+selectWeighted :: [(Int, a)] -> RVar a
+selectWeighted x = do
+  let total = Protolude.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)
+
+eval :: [BoundSymbol] -> SimplyTypedLambdaExpression ex -> ex
+eval bound (Abstraction rep stle) = lam bound rep stle
+eval bound (Application stleAtoB stleA) = (eval bound stleAtoB) (eval bound stleA)
+eval bound (VariableReference rep inx) = (getSymbolsOfType bound rep) !! inx
+eval _ (Constant res) = res
+
+lam :: [BoundSymbol] -> Ref.TypeRep a -> SimplyTypedLambdaExpression (b) -> (a -> b)
+lam bound Ref.TypeRep stle = \(aVal :: a) -> eval (appendToBoundVar bound aVal) stle
+
+appendToBoundVar :: (Typeable a) => [BoundSymbol] -> a -> [BoundSymbol]
+appendToBoundVar bv val = bv ++ [BoundSymbol (Ref.typeOf val) val Nothing]
+
+listAppend :: (Typeable a) => a -> Maybe [Dynamic] -> Maybe [Dynamic]
+listAppend val (Just dyns) = Just (dyns ++ [toDyn val])
+listAppend val (Nothing) = Just [toDyn val]
+
+getMinimasBy :: (Ord b) => (a -> b) -> [a] -> [a]
+getMinimasBy fun as = filter (\a -> fun a == minOverAs) as
+  where
+    minOverAs = minimum (map fun as)
+
+getMinimasByMaybe :: (Ord b) => (a -> Maybe b) -> [a] -> [a]
+getMinimasByMaybe fun as = filter (\a -> fun a == Just minOverAs) as
+  where
+    minOverAs = minimum (mapMaybe fun as)
+
+getMaximasBy :: (Ord b) => (a -> b) -> [a] -> [a]
+getMaximasBy fun as = filter (\a -> fun a == maxOverAs) as
+  where
+    maxOverAs = maximum (map fun as)
+
+getMaximasByMaybe :: (Ord b) => (a -> Maybe b) -> [a] -> [a]
+getMaximasByMaybe fun as = filter (\a -> fun a == Just maxOverAs) as
+  where
+    maxOverAs = maximum (mapMaybe fun as)

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,63 @@
+{-# 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]
+
+meanOfDistributionAccuracy :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
+meanOfDistributionAccuracy results = mean $ 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

@@ -0,0 +1,69 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+import Options.Applicative
+import Pipes
+import Protolude hiding (for)
+import System.IO
+import Seminar
+import Szenario191
+
+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 400
+          <> 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
+    let cfg = GaRunConfig {
+      enviroment = AssignmentEnviroment (students prios, topics prios),
+      initialEvaluator = prios,
+      selectionType = Tournament 3,
+      termination = (steps (iterations opts)),
+      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 seminarL s = do
+      let f = fitness' seminarL s
+      putErrText $ show f <> "\n" <> output (AssignmentEnviroment (students prios, topics prios)) s
+    logCsv = putText . csv
+    csv (t, f) = show t <> " " <> show f

src-students/Seminar.hs

@@ -107,6 +107,14 @@ instance Pretty AssignmentEnviroment where
   pretty (AssignmentEnviroment (persons,assignables)) = "Persons: " <> show persons <> " Assignables: " <> show assignables
 
 instance Environment Assignment AssignmentEnviroment where
+
+  output _ a =
+    T.unlines (gene <$> a)
+    where
+      gene :: (Maybe Student, Maybe Topic) -> Text
+      gene (s, t) =
+        pretty s <> ": " <> pretty t
+
   new (AssignmentEnviroment (persons,assignables)) = do
     let aPadding = replicate (length persons - length assignables) Nothing
     let paddedAssignables = (Just <$> assignables) ++ aPadding
@@ -127,8 +135,6 @@ instance Environment Assignment AssignmentEnviroment where
   --  Borrowed from TSP: Crossover cuts the parents in two and swaps them (if this
   --  does not create an invalid offspring).
   --
-  --  TODO Assumes that both individuals are based on the same priorities.
-  --
   crossover1 e assignment1 assignment2 = do
     let l = fromIntegral $ min (length assignment1) (length assignment2) :: Double
     x <- uniform 0 l
@@ -141,14 +147,6 @@ instance Environment Assignment AssignmentEnviroment 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
-
 -- |
 -- The priority value given by a student to a topic including the case of her not
 -- receiving a topic.

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/IrisData.hs.template

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

src/Test.hs

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