clean up, organize and document

lib/GA.hs

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

lib/LambdaCalculus.hs

@@ -0,0 +1,545 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module LambdaCalculus where
+
+import Data.List (foldr1, intersect, last, nub, (!!), (\\))
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map.Strict as Map
+import Data.Maybe
+import Data.Random
+import qualified Data.Text as T
+import Data.Tuple.Extra
+import Data.Typeable
+import Debug.Trace as DB
+import GA
+import Pretty
+import Protolude
+import Protolude.Error
+import Test.QuickCheck hiding (sample, shuffle)
+import Test.QuickCheck.Monadic (assert, monadicIO)
+import qualified Type.Reflection as Ref
+import Utils
+
+data ExpressionWeights = ExpressionWeights
+  { lambdaSpucker :: Int,
+    lambdaSchlucker :: Int,
+    symbol :: Int,
+    variable :: Int,
+    constant :: Int
+  }
+
+data LambdaEnviroment = LambdaEnviroment
+  { functions :: (Map TypeRep [ConVal]),
+    constants :: (Map TypeRep [RVar ConVal]),
+    targetType :: TypeRep,
+    maxDepth :: Int,
+    weights :: ExpressionWeights
+  }
+
+showSanifid :: (Show a) => a -> Text
+showSanifid var = T.replace " -> " "To" (show var)
+
+exampleLE :: LambdaEnviroment
+exampleLE =
+  LambdaEnviroment
+    { functions =
+        Map.fromList
+          [ ((Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int))), ["(+)", "(-)", "(*)", "mod"]),
+            ((Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Bool))), ["(>)", "(==)", "(>=)"]),
+            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Int -> Int -> Int))), ["if'"])
+          ],
+      constants =
+        Map.fromList
+          [ ((Ref.SomeTypeRep (Ref.TypeRep @(Int))), [(fmap show (uniform 0 10000 :: RVar Int))]),
+            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool))), [(fmap show (uniform True False :: RVar Bool))])
+          ],
+      targetType = (Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int))),
+      maxDepth = 10,
+      weights =
+        ExpressionWeights
+          { lambdaSpucker = 1,
+            lambdaSchlucker = 2,
+            symbol = 2,
+            variable = 10,
+            constant = 2
+          }
+    }
+
+type BoundVars = [TypeRep]
+
+-- we need a dynamic typ with a concept of equality here, should we want to interpret the result, instead of compiling it...
+type ConVal = Text
+
+-- LambdaSpucker - adds TypeRequester#1 as bound var and returns the result of TypeRequester#2
+
+data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show)
+
+asList :: LambdaExpression -> [TypeRequester]
+asList (LambdaSpucker tr1 tr2 _) = [tr1, tr2]
+asList (LambdaSchlucker tr _) = [tr]
+asList (Symbol _ trs _) = trs
+asList (Var _ _ trs _) = trs
+asList (Constan _) = []
+
+data TypeRequester = TR TypeRep (Maybe LambdaExpression) BoundVars deriving (Eq, Ord, Show)
+
+toLambdaExpressionS :: TypeRequester -> Text
+toLambdaExpressionS (TR typeRep (Just lambdaExpression) boundVars) = "((" <> eToLambdaExpressionS lambdaExpression <> ") :: (" <> show typeRep <> "))"
+toLambdaExpressionS (TR _ (Nothing) _) = "Invalid Lambda Epr"
+
+-- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show)
+
+eToLambdaExpressionS :: LambdaExpression -> Text
+eToLambdaExpressionS (LambdaSpucker typeRequester1 typeRequester2 boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionS typeRequester2 <> ") " <> toLambdaExpressionS typeRequester1
+eToLambdaExpressionS (LambdaSchlucker typeRequester boundVars) = "\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionS typeRequester
+eToLambdaExpressionS (Symbol (valS) typeRequesters _) = valS <> " " <> (unwords (map toLambdaExpressionS typeRequesters))
+eToLambdaExpressionS (Var typeRep int typeRequesters _) = "l" <> showSanifid typeRep <> show int <> " " <> (unwords (map toLambdaExpressionS typeRequesters))
+eToLambdaExpressionS (Constan (valS)) = valS
+
+instance Pretty TypeRequester where
+  pretty = toLambdaExpressionShort
+
+instance Individual TypeRequester
+
+instance Pretty LambdaEnviroment where
+  pretty (LambdaEnviroment functions constants target _ _) = "Functions: " <> show functions <> " Constants: " <> show (Map.keys constants) <> " Target is a function: " <> show target
+
+genTypeRequester :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar TypeRequester
+genTypeRequester env depthLeft target boundVars = do
+  le <- genLambdaExpression env (depthLeft - 1) target boundVars
+  return (TR target (Just le) boundVars)
+
+genLambdaExpression :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
+genLambdaExpression env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do
+  let weightMap =
+        ( if not (canGenSchlucker target)
+            then [(constant weights, genLambdaConst env depthLeft target boundVar)]
+            else []
+        )
+          <> ( if depthLeft > 0
+                 then [(lambdaSpucker weights, genLambdaSpucker env depthLeft target boundVar)]
+                 else []
+             )
+          <> ( if canGenSchlucker target
+                 then [(lambdaSchlucker weights, genLambdaSchlucker env depthLeft target boundVar)]
+                 else []
+             )
+          <> ( if depthLeft > 0 && doAnyMatchThatType target (Map.keys functions)
+                 then [(symbol weights, genLambdaSymbol env depthLeft target boundVar)]
+                 else []
+             )
+          <> ( if depthLeft > 0 && doAnyMatchThatType target boundVar
+                 then [(variable weights, genLambdaVar env depthLeft target boundVar)]
+                 else []
+             )
+  expres <- selectWeighted weightMap
+  res <- expres
+  return res
+
+selectWeighted :: [(Int, a)] -> RVar a
+selectWeighted x = do
+  let total = sum (map fst x)
+  selection <- uniform 1 total
+  return $ selectAtWeight selection (NE.fromList x)
+
+selectAtWeight :: Int -> NonEmpty (Int, a) -> a
+selectAtWeight _ (x :| []) = snd x
+selectAtWeight w (x :| xs)
+  | fst x >= w = snd x
+  | otherwise = selectAtWeight (w - fst x) (NE.fromList xs)
+
+canGenSchlucker :: TypeRep -> Bool
+canGenSchlucker t = (typeRepTyCon t) == (typeRepTyCon (Ref.SomeTypeRep (Ref.TypeRep @(->))))
+
+doAnyMatchThatType :: TypeRep -> [TypeRep] -> Bool
+doAnyMatchThatType toGen available = any (doTypesMatch toGen) available
+
+doTypesMatch :: TypeRep -> TypeRep -> Bool
+doTypesMatch toGen available = elem toGen (available : (repeatedly (lastMay . typeRepArgs) available))
+
+genLambdaSpucker :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
+genLambdaSpucker env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do
+  lamdaTypeLength <- uniform 1 4
+  lambaTypes <- replicateM lamdaTypeLength (randomElement (Map.keys constants))
+  let lambaType = foldr1 mkFunTy lambaTypes
+  lamdaVarTypeRequester <- genTypeRequester env depthLeft lambaType boundVar
+  typeRequester <- genTypeRequester env depthLeft target (boundVar ++ [lambaType])
+  return (LambdaSpucker lamdaVarTypeRequester typeRequester (boundVar ++ [lambaType]))
+
+genLambdaSchlucker :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
+genLambdaSchlucker env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do
+  let args = typeRepArgs target
+  let lambaType = fromJust (head args)
+  let toFind = last args
+  typeRequester <- genTypeRequester env (depthLeft + 1) toFind (boundVar ++ [lambaType])
+  return (LambdaSchlucker typeRequester (boundVar ++ [lambaType]))
+
+genLambdaConst :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
+genLambdaConst env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do
+  elm <- randomElement $ fromJust (Map.lookup target constants)
+  res <- elm
+  return $ Constan res
+
+genLambdaSymbol :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
+genLambdaSymbol env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do
+  let availFunTypes = filter (doTypesMatch target) (Map.keys functions)
+  (tr, fun) <- randomElement $ concatMap (\l -> zip (repeat l) (fromMaybe [] (Map.lookup l functions))) availFunTypes
+  ret <- genLambdaSymbol' tr fun [] env depthLeft target boundVar
+  return ret
+
+genLambdaSymbol' :: TypeRep -> ConVal -> [TypeRequester] -> LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
+genLambdaSymbol' tr v trs env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar
+  | tr == target = do
+      return $ Symbol v trs boundVar
+  | otherwise = do
+      let args = typeRepArgs tr
+      let param = fromJust (head args)
+      let rest = last args
+      newTypeRequ <- genTypeRequester env depthLeft param boundVar
+      ret <- genLambdaSymbol' rest v (trs ++ [newTypeRequ]) env depthLeft target boundVar
+      return ret
+
+genLambdaVar :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
+genLambdaVar env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do
+  let availTypes = filter (doTypesMatch target) boundVar
+  choosenType <- randomElement $ availTypes
+  let tCount = count boundVar choosenType
+  indexV <- uniform 0 (tCount - 1)
+  ret <- genLambdaVar' choosenType choosenType indexV [] env depthLeft target boundVar
+  return ret
+
+genLambdaVar' :: TypeRep -> TypeRep -> Int -> [TypeRequester] -> LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
+genLambdaVar' tr varType varNumber trs env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar
+  | tr == target = do
+      return $ Var varType varNumber trs boundVar
+  | otherwise = do
+      let args = typeRepArgs tr
+      let param = fromJust (head args)
+      let rest = last args
+      newTypeRequ <- genTypeRequester env depthLeft param boundVar
+      ret <- genLambdaVar' rest varType varNumber (trs ++ [newTypeRequ]) env depthLeft target boundVar
+      return ret
+
+instance Environment TypeRequester LambdaEnviroment where
+  new env@(LambdaEnviroment _ _ target maxDepth _) = do
+    tr <- genTypeRequester env maxDepth target []
+    return tr
+
+  mutate env@(LambdaEnviroment _ _ _ maxDepth _) tr = do
+    selfCrossover <- uniform True False
+    co <- crossover1 env tr tr
+    if selfCrossover && isJust co
+      then do
+        let (tr1, tr2) = fromJust co
+        return $ minimumBy (compare `on` countTrsR) [tr1, tr2]
+      else do
+        let trCount = countTrsR (tr)
+        selectedTR <- uniform 1 trCount
+        let (depthAt, (TR trep _ bound)) = depthLeftAndTypeAtR tr selectedTR maxDepth
+        res <- genTypeRequester env depthAt trep bound
+        return $ replaceAtR selectedTR tr res
+
+  nX _ = 3 -- todo!
+
+  crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do
+    let trCount = countTrsR tr1
+    selectedIndex1 <- uniform 1 trCount
+    let (depthAt1, selectedTr1@(TR _ _ bound1)) = depthLeftAndTypeAtR tr1 selectedIndex1 maxDepth
+    let depthLeftNeeded = depthOfTR selectedTr1
+    let indexes = findIndicesWhere tr2 (isCompatibleTr selectedTr1 (maxDepth - depthAt1) depthLeftNeeded) 0 0
+    if length indexes == 0
+      then return Nothing
+      else
+        ( do
+            (selectedTr2@(TR _ _ bound2), selectedIndex2) <- randomElement indexes
+            selectedTr2 <- adaptBoundVars selectedTr2 bound1
+            selectedTr1 <- adaptBoundVars selectedTr1 bound2
+            let child1 = replaceAtR selectedIndex1 tr1 selectedTr2
+            let child2 = replaceAtR selectedIndex2 tr2 selectedTr1
+            return $ Just (child1, child2)
+        )
+
+-- helper
+depthOfTR :: TypeRequester -> Int
+depthOfTR (TR _ (Just le@(LambdaSchlucker _ _)) _) = maximum (0:(map depthOfTR (asList le)))
+depthOfTR (TR _ (Just le) _) = maximum (0:(map depthOfTR (asList le))) + 1
+depthOfTR _ = error "le Not Just (depthOfTR)"
+
+adaptBoundVars :: TypeRequester -> BoundVars -> RVar TypeRequester
+adaptBoundVars tr@(TR _ _ bvOld) bvNew = do
+  newIndexMap <- generateConversionIndexMap bvOld bvNew
+  return $ convertTr tr bvOld bvNew newIndexMap
+
+convertTr :: TypeRequester -> BoundVars -> BoundVars -> Map TypeRep (Int -> Int) -> TypeRequester
+convertTr tr@(TR tRp (Just le) bvCurr) bvOld bvNew mapper = TR tRp (Just (convertLe le bvOld bvNew mapper)) (bvNew ++ (bvCurr \\ bvOld))
+convertTr _ _ _ _ = error "le Not Just (convertTr)"
+
+-- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show)
+convertLe :: LambdaExpression -> BoundVars -> BoundVars -> Map TypeRep (Int -> Int) -> LambdaExpression
+convertLe (LambdaSpucker tr1 tr2 bvCurr) bvOld bvNew mapper = LambdaSpucker (convertTrf tr1) (convertTrf tr2) (bvNew ++ (bvCurr \\ bvOld))
+  where
+    convertTrf tr = convertTr tr bvOld bvNew mapper
+convertLe (LambdaSchlucker tr bvCurr) bvOld bvNew mapper = LambdaSchlucker (convertTrf tr) (bvNew ++ (bvCurr \\ bvOld))
+  where
+    convertTrf tr = convertTr tr bvOld bvNew mapper
+convertLe (Symbol cv trs bvCurr) bvOld bvNew mapper = Symbol cv (map convertTrf trs) (bvNew ++ (bvCurr \\ bvOld))
+  where
+    convertTrf tr = convertTr tr bvOld bvNew mapper
+convertLe (Var varType varNumber trs bvCurr) bvOld bvNew mapper = Var varType ((fromMaybe identity (Map.lookup varType mapper)) varNumber) (map convertTrf trs) (bvNew ++ (bvCurr \\ bvOld))
+  where
+    convertTrf tr = convertTr tr bvOld bvNew mapper
+convertLe le@(Constan _) _ _ _ = le
+
+generateConversionIndexMap :: BoundVars -> BoundVars -> RVar (Map TypeRep (Int -> Int))
+generateConversionIndexMap bvOld bvNew = do
+  funcs <- mapM (\bT -> genMapper (count bvOld bT - 1) (count bvNew bT - 1)) (nub bvOld)
+  return $ Map.fromList $ zip (nub bvOld) funcs
+
+genMapper :: Int -> Int -> RVar (Int -> Int)
+genMapper i j
+  | i == j = return identity
+  | i < j = return $ \int -> if int <= i then int else int + (j - i)
+  | i > j = do
+      permutationForUnbound <- genPermutation i j
+      return $ genMapperRandomAssment i j permutationForUnbound
+  | otherwise = error "impossible case in genMapper"
+
+genMapperRandomAssment :: Int -> Int -> [Int] -> Int -> Int
+genMapperRandomAssment i j permutationForUnbound int
+  | int <= j = int
+  | int > i = int - (i - j)
+  | otherwise = permutationForUnbound !! (int - j - 1)
+
+genPermutation :: Int -> Int -> RVar [Int]
+genPermutation i j = replicateM (i - j) (uniform 0 j)
+
+isCompatibleTr :: TypeRequester -> Int -> Int -> TypeRequester -> Int -> Bool
+isCompatibleTr tr1@(TR trep1 _ bound1) maxDepthOfTR2 maxDepthOfNode tr2@(TR trep2 _ bound2) depthOfNode
+  | trep1 == trep2 = allUsedBound (usedVars bound1 tr1) bound2 && allUsedBound (usedVars bound2 tr2) bound1 && maxDepthOfTR2 >= (depthOfTR tr2) && maxDepthOfNode >= depthOfNode
+  | otherwise = False
+
+allUsedBound :: BoundVars -> BoundVars -> Bool
+allUsedBound used available = all (\x -> any (== x) available) used
+
+usedVars :: BoundVars -> TypeRequester -> BoundVars
+usedVars boundOld tr@(TR trep1 (Just (Var trp ind trs _)) _) = if any (== trp) boundOld && count boundOld trp > ind then trp : concatMap (usedVars boundOld) trs else concatMap (usedVars boundOld) trs
+usedVars boundOld tr@(TR trep1 (Just le) _) = concatMap (usedVars boundOld) (asList le)
+usedVars _ _ = error "Nothing in usedVars"
+
+boundsConvertable :: BoundVars -> BoundVars -> Bool
+boundsConvertable bv1 bv2 = length (nub bv2) == length (nub bv1) && length (intersect (nub bv1) bv2) == length (nub bv1)
+
+findIndicesWhere :: TypeRequester -> (TypeRequester -> Int -> Bool) -> Int -> Int -> [(TypeRequester, Int)]
+findIndicesWhere tr@(TR _ (Just le@(LambdaSchlucker _ _)) _) filte indx currDepth = if filte tr currDepth then (tr, indx + 1) : (findIndicesWhere' (asList le) filte (indx + 1) (currDepth)) else (findIndicesWhere' (asList le) filte (indx + 1) (currDepth))
+findIndicesWhere tr@(TR _ lE _) filte indx currDepth = case lE of
+  Just le -> if filte tr currDepth then (tr, indx + 1) : (findIndicesWhere' (asList le) filte (indx + 1) (currDepth + 1)) else (findIndicesWhere' (asList le) filte (indx + 1) (currDepth + 1))
+  Nothing -> error "Nothing in findIndicesWhere"
+
+findIndicesWhere' :: [TypeRequester] -> (TypeRequester -> Int -> Bool) -> Int -> Int -> [(TypeRequester, Int)]
+findIndicesWhere' [] _ _ _ = []
+findIndicesWhere' [tr] f indx currDepth = (findIndicesWhere tr f indx currDepth)
+findIndicesWhere' (tr : trs) f indx currDepth = (findIndicesWhere tr f indx currDepth) ++ (findIndicesWhere' trs f (indx + countTrsR tr) currDepth)
+
+replaceAtR :: Int -> TypeRequester -> TypeRequester -> TypeRequester
+replaceAtR 1 _ with = with
+replaceAtR i (TR tm (Just le) bV) with = TR tm (Just (replaceAt (i - 1) le with)) bV
+replaceAtR _ (TR _ Nothing _) _ = error "Nothing in replaceAtR"
+
+replaceAt :: Int -> LambdaExpression -> TypeRequester -> LambdaExpression
+replaceAt i le@(LambdaSpucker _ _ bv) with = LambdaSpucker (fromJust (head trs)) (last trs) bv where trs = replaceInSubtreeWithIndex i (asList le) with
+replaceAt i (LambdaSchlucker tr bv) with = LambdaSchlucker (replaceAtR i tr with) bv
+replaceAt i le@(Symbol cv _ bv) with = Symbol cv trs bv where trs = replaceInSubtreeWithIndex i (asList le) with
+replaceAt i le@(Var tr ix _ bv) with = Var tr ix trs bv where trs = replaceInSubtreeWithIndex i (asList le) with
+replaceAt _ (Constan _) _ = error "Nothing in replaceAt"
+
+replaceInSubtreeWithIndex :: Int -> [TypeRequester] -> TypeRequester -> [TypeRequester]
+replaceInSubtreeWithIndex indexLeft (tr : trs) with = if countTrsR tr >= indexLeft then (replaceAtR indexLeft tr with) : trs else tr : (replaceInSubtreeWithIndex (indexLeft - countTrsR tr) trs with)
+replaceInSubtreeWithIndex _ [] _ = error "Index not found in replaceInSubtreeWithIndex"
+
+depthLeftAndTypeAtR :: TypeRequester -> Int -> Int -> (Int, TypeRequester)
+depthLeftAndTypeAtR t 1 depthLeft = ((depthLeft - 1), t)
+depthLeftAndTypeAtR (TR _ (Just le) _) indexLeft depthLeft = depthLeftAndTypeAt le (indexLeft - 1) (depthLeft - 1)
+depthLeftAndTypeAtR (TR _ Nothing _) indexLeft depthLeft = error "Nothing in depthLeftAndTypeAtR"
+
+depthLeftAndTypeAt :: LambdaExpression -> Int -> Int -> (Int, TypeRequester)
+depthLeftAndTypeAt le@(LambdaSchlucker tr bv) indexLeft depthLeft = depthLeftAndTypeInSubtreeWithIndex (asList le) indexLeft (depthLeft + 1)
+depthLeftAndTypeAt le indexLeft depthLeft = depthLeftAndTypeInSubtreeWithIndex (asList le) indexLeft depthLeft
+
+depthLeftAndTypeInSubtreeWithIndex :: [TypeRequester] -> Int -> Int -> (Int, TypeRequester)
+depthLeftAndTypeInSubtreeWithIndex (tr : trs) indexLeft depthLeft = if countTrsR tr >= indexLeft then depthLeftAndTypeAtR tr indexLeft depthLeft else depthLeftAndTypeInSubtreeWithIndex trs (indexLeft - countTrsR tr) depthLeft
+depthLeftAndTypeInSubtreeWithIndex [] indexLeft depthLeft = error "Index not found in depthLeftAndTypeInSubtreeWithIndex"
+
+countTrsR :: TypeRequester -> Int
+countTrsR tr@(TR t lE _) = case lE of
+  Just le -> countTrs le + 1
+  Nothing -> 1
+
+countTrs :: LambdaExpression -> Int
+countTrs le = sum (map countTrsR (asList le))
+
+-- Test Stuff
+
+testConstInt :: TypeRequester
+testConstInt = TR (Ref.SomeTypeRep (Ref.TypeRep @Int)) (Just (Symbol ("5") [] [])) []
+
+testIntToClassCons :: TypeRequester
+testIntToClassCons = TR (Ref.SomeTypeRep (Ref.TypeRep @(Int -> ResClass))) (Just (Symbol ("Class1") [] [])) []
+
+testIntToClassCorrect :: TypeRequester
+testIntToClassCorrect =
+  TR
+    (Ref.SomeTypeRep (Ref.TypeRep @(Int -> ResClass)))
+    ( Just
+        ( LambdaSchlucker
+            ( TR
+                (Ref.SomeTypeRep (Ref.TypeRep @(ResClass)))
+                ( Just
+                    ( Symbol
+                        ("iteClass")
+                        [ ( TR
+                              (Ref.SomeTypeRep (Ref.TypeRep @(Bool)))
+                              ( Just
+                                  ( Symbol
+                                      ("eqInt")
+                                      [ ( TR
+                                            (Ref.SomeTypeRep (Ref.TypeRep @(Int)))
+                                            (Just (Var (Ref.SomeTypeRep (Ref.TypeRep @(Int))) 0 [] []))
+                                            [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                        ),
+                                        ( TR
+                                            (Ref.SomeTypeRep (Ref.TypeRep @(Int)))
+                                            (Just (Constan ("1")))
+                                            [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                        )
+                                      ]
+                                      [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                  )
+                              )
+                              [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                          ),
+                          ( TR
+                              (Ref.SomeTypeRep (Ref.TypeRep @(ResClass)))
+                              (Just (Constan ("Class1")))
+                              [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                          ),
+                          ( TR
+                              (Ref.SomeTypeRep (Ref.TypeRep @(ResClass)))
+                              ( Just
+                                  ( Symbol
+                                      ("iteClass")
+                                      [ ( TR
+                                            (Ref.SomeTypeRep (Ref.TypeRep @(Bool)))
+                                            ( Just
+                                                ( Symbol
+                                                    ("eqInt")
+                                                    [ ( TR
+                                                          (Ref.SomeTypeRep (Ref.TypeRep @(Int)))
+                                                          (Just (Var (Ref.SomeTypeRep (Ref.TypeRep @(Int))) 0 [] []))
+                                                          [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                      ),
+                                                      ( TR
+                                                          (Ref.SomeTypeRep (Ref.TypeRep @(Int)))
+                                                          (Just (Constan ("2")))
+                                                          [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                      )
+                                                    ]
+                                                    [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                )
+                                            )
+                                            [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                        ),
+                                        ( TR
+                                            (Ref.SomeTypeRep (Ref.TypeRep @(ResClass)))
+                                            (Just (Constan ("Class2")))
+                                            [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                        ),
+                                        ( TR
+                                            (Ref.SomeTypeRep (Ref.TypeRep @(ResClass)))
+                                            ( Just
+                                                ( Symbol
+                                                    ("iteClass")
+                                                    [ ( TR
+                                                          (Ref.SomeTypeRep (Ref.TypeRep @(Bool)))
+                                                          ( Just
+                                                              ( Symbol
+                                                                  ("eqInt")
+                                                                  [ ( TR
+                                                                        (Ref.SomeTypeRep (Ref.TypeRep @(Int)))
+                                                                        (Just (Var (Ref.SomeTypeRep (Ref.TypeRep @(Int))) 0 [] []))
+                                                                        [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                                    ),
+                                                                    ( TR
+                                                                        (Ref.SomeTypeRep (Ref.TypeRep @(Int)))
+                                                                        (Just (Constan ("3")))
+                                                                        [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                                    )
+                                                                  ]
+                                                                  [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                              )
+                                                          )
+                                                          [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                      ),
+                                                      ( TR
+                                                          (Ref.SomeTypeRep (Ref.TypeRep @(ResClass)))
+                                                          (Just (Constan ("Class3")))
+                                                          [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                      ),
+                                                      ( TR
+                                                          (Ref.SomeTypeRep (Ref.TypeRep @(ResClass)))
+                                                          (Just (Constan ("Class3")))
+                                                          [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                      )
+                                                    ]
+                                                    [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                                )
+                                            )
+                                            [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                        )
+                                      ]
+                                      [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                                  )
+                              )
+                              [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                          )
+                        ]
+                        [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+                    )
+                )
+                [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+            )
+            [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))]
+        )
+    )
+    []
+
+data ResClass = Class1 | Class2 | Class3 deriving (Enum, Show)
+
+eqInt :: Int -> Int -> Bool
+eqInt a b = a == b
+
+iteClass :: Bool -> ResClass -> ResClass -> ResClass
+iteClass True c _ = c
+iteClass False _ c = c
+
+toLambdaExpressionShort :: TypeRequester -> Text
+toLambdaExpressionShort (TR _ (Just lambdaExpression) _) = "(" <> eToLambdaExpressionShort lambdaExpression <> ")"
+toLambdaExpressionShort (TR _ (Nothing) _) = "Invalid Lambda Epr"
+
+-- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int | Constan ConVal
+
+eToLambdaExpressionShort :: LambdaExpression -> Text
+eToLambdaExpressionShort (LambdaSpucker typeRequester1 typeRequester2 boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionShort typeRequester2 <> ") " <> toLambdaExpressionShort typeRequester1
+eToLambdaExpressionShort (LambdaSchlucker typeRequester boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionShort typeRequester <> ")"
+eToLambdaExpressionShort (Symbol (valS) typeRequesters _) = valS <> " " <> (unwords (map toLambdaExpressionShort typeRequesters))
+eToLambdaExpressionShort (Var typeRep int typeRequesters _) = "l" <> showSanifid typeRep <> show int <> " " <> (unwords (map toLambdaExpressionShort typeRequesters))
+eToLambdaExpressionShort (Constan (valS)) = valS
+
+res :: Int -> ResClass
+res = ((\lInt0 -> ((iteClass ((eqInt ((lInt0) :: (Int)) ((1) :: (Int))) :: (Bool)) ((Class1) :: (ResClass)) ((iteClass ((eqInt ((lInt0) :: (Int)) ((2) :: (Int))) :: (Bool)) ((Class2) :: (ResClass)) ((iteClass ((eqInt ((lInt0) :: (Int)) ((3) :: (Int))) :: (Bool)) ((Class3) :: (ResClass)) ((Class3) :: (ResClass))) :: (ResClass))) :: (ResClass))) :: (ResClass))) :: (Int -> ResClass))

lib/Pretty.hs

@@ -0,0 +1,8 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Pretty where
+
+import Protolude
+
+class Pretty a where
+  pretty :: a -> Text

lib/Test.hs

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

lib/Utils.hs

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