fix Iris

haga.cabal

@@ -40,7 +40,6 @@ library
                      , random
                      , random-fu
                      , random-shuffle
-                     , semirings
                      , text
                      , wl-pprint-text
   default-language:    Haskell2010
@@ -49,7 +48,6 @@ library
   other-modules:       CommonDefinition
   exposed-modules:     GA
                      , LambdaCalculus
-                     , LambdaCalculusV2
                      , Pretty
                      , Utils
                      , LambdaDatasets.NurseryDefinition

lambda/lib/LambdaDatasets/NurseryDefinition.hs

@@ -13,28 +13,20 @@ 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

@@ -38,7 +38,7 @@ lE =
             ((Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int))), ["(+)", "(-)", "(*)"]),
             -- Logic
             ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
-            -- Ordered Enums
+            -- Ordered
             ((Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
             ((Ref.SomeTypeRep (Ref.TypeRep @(AccountStatus -> AccountStatus -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
             ((Ref.SomeTypeRep (Ref.TypeRep @(CreditHistory -> CreditHistory -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
@@ -46,7 +46,7 @@ lE =
             ((Ref.SomeTypeRep (Ref.TypeRep @(EmploymentStatus -> EmploymentStatus -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
             ((Ref.SomeTypeRep (Ref.TypeRep @(OtherDebtors -> OtherDebtors -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
             ((Ref.SomeTypeRep (Ref.TypeRep @(Job -> Job -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-            -- Eq Enum
+            -- Eq
             ((Ref.SomeTypeRep (Ref.TypeRep @(GermanClass -> GermanClass -> Bool))), ["(==)", "(/=)"]),
             ((Ref.SomeTypeRep (Ref.TypeRep @(Purpose -> Purpose -> Bool))), ["(==)", "(/=)"]),
             ((Ref.SomeTypeRep (Ref.TypeRep @(StatusAndSex -> StatusAndSex -> Bool))), ["(==)", "(/=)"]),
@@ -55,7 +55,7 @@ lE =
             ((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 -> GermanClass -> GermanClass -> GermanClass))), ["if'"]),
             ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> AccountStatus -> AccountStatus -> AccountStatus))), ["if'"]),
             ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> CreditHistory -> CreditHistory -> CreditHistory))), ["if'"]),
             ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Purpose -> Purpose -> Purpose))), ["if'"]),
@@ -86,13 +86,13 @@ lE =
             ((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,
+      maxDepth = 9,
       weights =
         ExpressionWeights
-          { lambdaSpucker = 1,
-            lambdaSchlucker = 2,
-            symbol = 30,
-            variable = 10,
+          { lambdaSpucker = 10,
+            lambdaSchlucker = 1,
+            symbol = 20,
+            variable = 100,
             constant = 5
           }
     }

lambda/src/LambdaDatasets/IrisDataset.hs

@@ -34,12 +34,17 @@ lE =
   LambdaEnviroment
     { functions =
         Map.fromList
-          [ ((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float))), ["(+)", "(-)", "(*)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Bool))), ["(>)", "(==)", "(>=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(IrisClass -> IrisClass -> Bool))), ["(==)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Float -> Float -> Float))), ["if'","if'","if'","if'","if'","if'","if'","if'"]),
+          [  -- Math
+            ((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float))), ["(+)", "(-)", "(*)"]),
+            -- Logic
             ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> IrisClass -> IrisClass -> IrisClass))), ["if'","if'","if'","if'","if'","if'","if'","if'","if'","if'"])
+            -- Ordered
+            ((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
+            -- Eq
+            ((Ref.SomeTypeRep (Ref.TypeRep @(IrisClass -> IrisClass -> Bool))), ["(==)","(/=)"]),
+            -- Any Type
+            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Float -> Float -> Float))), ["if'"]),
+            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> IrisClass -> IrisClass -> IrisClass))), ["if'"])
           ],
       constants =
         Map.fromList
@@ -48,12 +53,12 @@ lE =
             ((Ref.SomeTypeRep (Ref.TypeRep @(IrisClass))), [(fmap show (enumUniform Setosa Versicolor :: RVar IrisClass))])
           ],
       targetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
-      maxDepth = 10,
+      maxDepth = 9,
       weights =
         ExpressionWeights
-          { lambdaSpucker = 1,
+          { lambdaSpucker = 10,
             lambdaSchlucker = 1,
-            symbol = 30,
+            symbol = 20,
             variable = 100,
             constant = 5
           }
@@ -63,7 +68,7 @@ lEE :: LamdaExecutionEnv
 lEE =
   LamdaExecutionEnv
     { -- For now these need to define all available functions and types. Generic functions can be used.
-      imports = ["LambdaDatasets.IrisDataset"],
+      imports = ["LambdaDatasets.IrisDefinition"],
       training = True,
       trainingData =
         ( map fst (takeFraktion 0.8 irisTrainingData),
@@ -84,7 +89,7 @@ shuffledLEE = do
   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"],
+      imports = ["LambdaDatasets.IrisDefinition"],
       training = True,
       trainingData =
         ( map fst (takeFraktion 0.8 itD),

lambda/src/LambdaDatasets/NurseryDataset.hs

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

lambda/src/Main.hs

@@ -5,6 +5,7 @@
 
 import Options.Applicative
 import Pipes
+import Pretty
 import Protolude hiding (for)
 import System.IO
 -- import LambdaDatasets.IrisDataset
@@ -26,7 +27,7 @@ options =
       ( long "iterations"
           <> short 'i'
           <> metavar "N"
-          <> value 1
+          <> value 1500
           <> help "Number of iterations"
       )
     <*> option
@@ -58,7 +59,7 @@ main =
       selectionType = Tournament 3,
       termination = (steps (iterations opts)),
       poulationSize = (populationSize opts),
-      nParents = 120,
+      stepSize = 90,
       elitismRatio = 5/100
     }
     pop' <- runEffect (for (run cfg) logCsv)
@@ -70,6 +71,6 @@ main =
   where
     format l s = do
       let f = fitness' l s
-      putErrText $ show f <> "\n" <> output (lE) s
+      putErrText $ show f <> "\n" <> pretty s
     logCsv = putText . csv
     csv (t, f) = show t <> " " <> show f

lib/GA.hs

@@ -24,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 (..), Fitness (..), Evaluator (..), Individual, GA.run, Tournament (..), N, R, Population, steps, bests, runTests, GaRunConfig (..)) 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 ((<|))
@@ -51,9 +51,7 @@ type R = Double
 -- |
 --  An Environment that Individuals of type i can be created from
 --  It stores all information required to create and change Individuals correctly
-class (Individual i) => Environment i e | e -> i, i -> e where
-  output :: e -> i -> Text
-
+class (Pretty e, Individual i) => Environment i e | e -> i, i -> e where
   -- |
   --  Generates a completely random individual.
   new :: e -> RVar i
@@ -90,7 +88,7 @@ class (Individual i) => Environment i e | e -> i, i -> e where
 -- |
 --  An Evaluator that Individuals of type i can be evaluated by
 --  It stores all information required to evaluate an individuals fitness
-class (Individual i, Fitness r) => Evaluator i e r | e -> i r where
+class (Individual i, Fitness r) => Evaluator i e r | e -> i r, i -> e where
   -- |
   --  An individual's fitness. Higher values are considered “better”.
   --
@@ -109,9 +107,10 @@ class (Individual i, Fitness r) => Evaluator i e r | e -> i r where
   -- 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 _ = return eval
+  calc eval _ = do
+    return eval
 
-class (Ord i) => Individual i
+class (Pretty i, Ord i) => Individual i
 
 class (Show i) => Fitness i where
   getR :: i -> R
@@ -325,18 +324,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, Show) -- IntTestEnviroment ((0,100000),10)
+newtype IntTestEnviroment = IntTestEnviroment ((Integer, Integer), Integer, N) deriving (Eq) -- IntTestEnviroment ((0,100000),10)
 
 instance Pretty IntTestEnviroment where
   -- instance Pretty (Maybe Student) where
   pretty (IntTestEnviroment ((i, j), k, _)) = "IntTestEnviroment of Individuals between " <> (show i) <> " and " <> (show j) <> " variance when mutating is " <> (show k)
 
 instance Environment Integer IntTestEnviroment where
-  output _ i = "Found int: " <> show i
-
   new (IntTestEnviroment ((from, to), _, _)) = uniform from to
 
   nX (IntTestEnviroment ((_, _), _, n)) = n

lib/LambdaCalculusV2.hs

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

@@ -20,9 +20,6 @@ geomeanOfAccuricyPerClass results = geomean $ map (accuracyInClass results) [min
 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
 

src-students/Main.hs

@@ -4,6 +4,7 @@
 
 import Options.Applicative
 import Pipes
+import Pretty
 import Protolude hiding (for)
 import System.IO
 import Seminar
@@ -64,6 +65,6 @@ main =
   where
     format seminarL s = do
       let f = fitness' seminarL s
-      putErrText $ show f <> "\n" <> output (AssignmentEnviroment (students prios, topics prios)) s
+      putErrText $ show f <> "\n" <> pretty s
     logCsv = putText . csv
     csv (t, f) = show t <> " " <> show f

src-students/Seminar.hs

@@ -107,14 +107,6 @@ 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
@@ -147,6 +139,14 @@ 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.