haga.cabal

@@ -50,7 +50,6 @@ library
                      , Szenario191
                      , LambdaCalculus
                      , IrisDataset
-                     , IrisData
 
 executable haga
   build-depends:       base
@@ -84,7 +83,6 @@ executable haga
                      , Szenario191
                      , LambdaCalculus
                      , IrisDataset
-                     , IrisData
 
 executable haga-test
   build-depends:       base
@@ -119,4 +117,3 @@ executable haga-test
                      , Szenario191
                      , LambdaCalculus
                      , IrisDataset
-                     , IrisData

src/GA.hs

@@ -20,7 +20,7 @@
 -- In order to use it for a certain problem, basically, you have to make your
 -- solution type an instance of 'Individual' and then simply call the 'run'
 -- function.
-module GA (Environment, new, population, mutate, crossover1, crossover, nX, Fitness, getR, Evaluator, fitness,fitness', calc, Individual, GA.run, Tournament (..), N, R, Population, steps, bests, runTests) where
+module GA (Environment, new, population, mutate, crossover1, crossover, nX, Evaluator, fitness, calc, Individual, GA.run, Tournament (..), N, R, Population, steps, bests, runTests) where
 
 import Control.Arrow hiding (first, second)
 import Data.List.NonEmpty ((<|))
@@ -83,16 +83,13 @@ class (Pretty e, Individual i) => Environment i e | e -> i where
 -- |
 --  An Evaluator that Individuals of type i can be evaluated by
 --  It stores all information required to evaluate an individuals fitness
-class (Individual i, Fitness r) => Evaluator i e r | i -> e r where
+class (Individual i) => Evaluator i e where
   -- |
   --  An individual's fitness. Higher values are considered “better”.
   --
   --  We explicitely allow fitness values to be have any sign (see, for example,
   --  'proportionate1').
   fitness :: e -> i -> R
-  fitness env i = getR ( fitness' env i)
-
-  fitness' :: e -> i -> r
 
   -- TODO kinda hacky?!?
   calc :: e -> Population i -> IO e
@@ -101,12 +98,6 @@ class (Individual i, Fitness r) => Evaluator i e r | i -> e r where
 
 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
@@ -158,18 +149,18 @@ bestsBy' k f 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 :: (Individual i, Evaluator i e) => 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 :: (Individual i, Evaluator i e) => 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) =>
+  (Individual i, Environment i env, Evaluator i eval, SelectionType s) =>
   eval ->
   env ->
   -- | Mechanism for selecting parents
@@ -179,13 +170,13 @@ reproduce ::
   Population i ->
   RVar (Population i)
 reproduce eval env selectT nParents pop = do
-  iParents <-select selectT nParents pop eval
+  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) =>
+  (Individual i, Evaluator i eval) =>
   eval ->
   -- | Elitism ratio @pElite@
   R ->
@@ -206,7 +197,7 @@ selectBest eval pElite pop nPop = do
         else return $ elitists <> (fst $ bests eval (nPop - length elitists) (NE.fromList rest))
 
 run ::
-  (Individual i, Evaluator i eval r, Environment i env, SelectionType s) =>
+  (Individual i, Evaluator i eval, Environment i env, SelectionType s) =>
   eval ->
   env ->
   -- | Mechanism for selecting parents
@@ -218,15 +209,18 @@ run ::
   -- | Population size
   N ->
   Termination i ->
-  Producer (Int, r) IO (Population 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)
+  _ <- liftIO $ putText $ pretty $ NE.head firstPop
+  firstPop <- liftIO $ smpl $ (population env nPop)
+  _ <- liftIO $ putText $ pretty $ NE.head firstPop
   res <- runIter eval 0 firstPop smpl
   return res
   where
-    runIter eval count pop smpl = (
+    runIter eval count pop smpl =
       if term pop count
         then do
           return pop
@@ -235,10 +229,10 @@ run eval env selectionType nParents pElite nPop term = do
           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
+          let fBest = fitness eval $ NE.head $ fst $ bests eval 1 resPop
           Pipes.yield (count, fBest)
           res <- runIter eval (count + 1) resPop smpl
-          return res)
+          return res
 
 -- * Selection mechanisms
 
@@ -248,7 +242,7 @@ run eval env selectionType nParents pElite nPop term = do
 data Tournament = Tournament N
 
 class SelectionType t where
-  select :: (Individual i, Evaluator i e r) => t -> N -> Population i -> e -> RVar (NonEmpty i)
+  select :: (Individual i, Evaluator i e) => t -> N -> Population i -> e -> RVar (NonEmpty i)
 
 -- type Selection m i = N -> Population i -> m (NonEmpty i)
 
@@ -258,7 +252,7 @@ instance SelectionType Tournament where
 -- |
 -- Selects one individual from the population using tournament selection.
 tournament1 ::
-  (Individual i, Evaluator i e r) =>
+  (Individual i, Evaluator i e) =>
   e ->
   -- | Tournament size
   N ->
@@ -329,7 +323,7 @@ instance Environment Integer IntTestEnviroment where
 
 data NoData = NoData deriving (Eq)
 
-instance Evaluator Integer NoData Double where
+instance Evaluator Integer NoData where
   fitness _ = fromIntegral . negate
 
 prop_children_asManyAsParents ::

src/IrisDataset.hs

@@ -1,149 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module IrisDataset
-  ( module LambdaCalculus,
-    module IrisDataset,
-    module IrisData,
-    module GA,
-  )
-where
-
-import qualified Data.ByteString.Lazy as B
-import Data.Csv
-import qualified Data.List.NonEmpty as NE
-import qualified Data.Map.Strict as Map
-import Data.Random
-import Data.Random.Distribution.Uniform
-import qualified Data.Text as T
-import Data.Tuple.Extra
-import qualified Debug.Trace as DB
-import GA
-import LambdaCalculus
-import IrisData
-import qualified Language.Haskell.Interpreter as Hint
-import qualified Language.Haskell.Interpreter.Unsafe as Hint
-import Protolude
-import qualified Type.Reflection as Ref
-
-irisLE :: LambdaEnviroment
-irisLE =
-  LambdaEnviroment
-    { functions =
-        Map.fromList
-          [ ((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float))), ["(+)", "(-)", "(*)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Bool))), ["(>)", "(==)", "(>=)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(IrisClass -> IrisClass -> Bool))), ["(==)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Float -> Float -> Float))), ["if'"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> IrisClass -> IrisClass -> IrisClass))), ["if'"])
-          ],
-      constants =
-        Map.fromList
-          [ ((Ref.SomeTypeRep (Ref.TypeRep @(Float))), [(fmap show (uniform 0 10 :: RVar Float))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(Bool))), [(fmap show (uniform True False :: RVar Bool))]),
-            ((Ref.SomeTypeRep (Ref.TypeRep @(IrisClass))), [(fmap show (enumUniform Setosa Versicolor :: RVar IrisClass))])
-          ],
-      targetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
-      maxDepth = 10,
-      weights =
-        ExpressionWeights
-          { lambdaSpucker = 1,
-            lambdaSchlucker = 1,
-            symbol = 1,
-            variable = 2,
-            constant = 1
-          }
-    }
-
-irisLEE :: LamdaExecutionEnv
-irisLEE =
-  LamdaExecutionEnv
-    { -- For now these need to define all available functions and types. Generic functions can be used.
-      imports = ["IrisDataset"],
-      -- Path to a CSV file containing the training dataset
-      trainingDataset = "./iris.csv",
-      -- Path to a CSV file containing the dataset results
-      trainingDatasetRes = "./res.csv",
-      trainingData =
-        ( map fst irisTrainingData,
-          map snd irisTrainingData
-        ),
-      exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
-      -- todo: kindaHacky
-      results = Map.empty
-    }
-
-data LamdaExecutionEnv = LamdaExecutionEnv
-  { -- For now these need to define all available functions and types. Generic functions can be used.
-    imports :: [Text],
-    -- Path to a CSV file containing the training dataset
-    trainingDataset :: FilePath,
-    -- Path to a CSV file containing the dataset results
-    trainingDatasetRes :: FilePath,
-    trainingData :: ([(Float, Float, Float, Float)], [IrisClass]),
-    exTargetType :: TypeRep,
-    -- todo: kindaHacky
-    results :: Map TypeRequester FittnesRes
-  }
-
-data FittnesRes = FittnesRes
-  { total :: R,
-    fitnessTotal :: R,
-    fitnessGeoMean :: R,
-    fitnessMean :: R,
-    accuracy :: Int,
-    biasDist :: R,
-    biasSize :: R
-  }
-  deriving (Show)
-
-instance Fitness FittnesRes where
-  getR = total
-
-instance Evaluator TypeRequester LamdaExecutionEnv FittnesRes where
-  fitness' env tr = (results env) Map.! tr
-
-  calc env pop = do
-    let toAdd = NE.filter (\k -> not (Map.member k (results env))) pop
-    toInsert <- Hint.runInterpreter (evalResults env toAdd)
-    let insertPair (key, val) m = Map.insert key val m
-    let res = foldr insertPair (results env) (fromRight undefined toInsert)
-    return env {results = res}
-
-
-evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, FittnesRes)]
-evalResults ex trs = mapM (evalResult ex) trs
-
-evalResult :: LamdaExecutionEnv -> TypeRequester -> Hint.InterpreterT IO (TypeRequester, FittnesRes)
-evalResult ex tr = do
-  Hint.setImports $ (map T.unpack (imports ex)) ++ ["Protolude"]
-  Hint.unsafeSetGhcOption "-O2"
-  result <- Hint.interpret (T.unpack (toLambdaExpressionS tr)) (Hint.as :: Float -> Float -> Float -> Float -> IrisClass)
-  let res = map (\(a, b, c, d) -> result a b c d) (fst (trainingData ex))
-  let resAndTarget = (zip (snd (trainingData ex)) res)
-  let acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) :: Int
-  let biasWellDistributed = (foldr (*) 1 (map (\ty -> (foldr (\ts s -> if ((snd ts) == ty) then s + 1 else s) 1 resAndTarget)) ([minBound .. maxBound] :: [IrisClass]) :: [R])) ** (1 / 3) -- 1 (schlecht) bis 51 (gut)
-  let biasSmall = exp (-(fromIntegral (countTrsR tr))) -- 0 (schlecht) bis 1 (gut)
-  let fitness' = meanOfAccuricyPerClass resAndTarget
-  let score = fitness' + (biasSmall - 1)
-  return
-    ( tr,
-      FittnesRes
-        { total = score,
-          fitnessTotal = fitness',
-          fitnessMean = meanOfAccuricyPerClass resAndTarget,
-          fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
-          accuracy = acc,
-          biasDist = biasWellDistributed,
-          biasSize = biasSmall
-        }
-    )
-
-if' :: Bool -> a -> a -> a
-if' True e _ = e
-if' False _ e = e
-

src/LambdaCalculus.hs

@@ -62,22 +62,21 @@ exampleLE =
       weights =
         ExpressionWeights
           { lambdaSpucker = 1,
-            lambdaSchlucker = 2,
+            lambdaSchlucker = 1,
-            symbol = 2,
+            symbol = 1,
-            variable = 10,
+            variable = 1,
-            constant = 2
+            constant = 1
           }
     }
 
 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)
+data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord)
 
 asList :: LambdaExpression -> [TypeRequester]
 asList (LambdaSpucker tr1 tr2 _) = [tr1, tr2]
@@ -86,7 +85,7 @@ asList (Symbol _ trs _) = trs
 asList (Var _ _ trs _) = trs
 asList (Constan _) = []
 
-data TypeRequester = TR TypeRep (Maybe LambdaExpression) BoundVars deriving (Eq, Ord, Show)
+data TypeRequester = TR TypeRep (Maybe LambdaExpression) BoundVars deriving (Eq, Ord)
 
 toLambdaExpressionS :: TypeRequester -> Text
 toLambdaExpressionS (TR typeRep (Just lambdaExpression) boundVars) = "((" <> eToLambdaExpressionS lambdaExpression <> ") :: (" <> show typeRep <> "))"
@@ -164,7 +163,7 @@ doTypesMatch toGen available = elem toGen (available : (repeatedly (lastMay . ty
 
 genLambdaSpucker :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
 genLambdaSpucker env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do
-  lamdaTypeLength <- uniform 1 4
+  lamdaTypeLength <- uniform 1 3
   lambaTypes <- replicateM lamdaTypeLength (randomElement (Map.keys constants))
   let lambaType = foldr1 mkFunTy lambaTypes
   lamdaVarTypeRequester <- genTypeRequester env depthLeft lambaType boundVar
@@ -261,7 +260,7 @@ instance Environment TypeRequester LambdaEnviroment where
 -- findIndicesWhere' (tr:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr))
 
 replaceAtR :: Int -> TypeRequester -> TypeRequester -> TypeRequester
-replaceAtR 1 _ with = with
+replaceAtR 0 _ with = with
 replaceAtR i (TR tm (Just le) bV) with = TR tm (Just (replaceAt (i - 1) le with)) bV
 replaceAtR _ (TR _ Nothing _) _ = undefined
 
@@ -277,7 +276,7 @@ replaceInSubtreeWithIndex indexLeft (tr : trs) with = if countTrsR tr >= indexLe
 replaceInSubtreeWithIndex _ [] _ = undefined
 
 depthLeftAndTypeAtR :: TypeRequester -> Int -> Int -> (Int, TypeRequester)
-depthLeftAndTypeAtR t 1 depthLeft = ((depthLeft - 1), t)
+depthLeftAndTypeAtR t 0 depthLeft = ((depthLeft - 1), t)
 depthLeftAndTypeAtR (TR _ (Just le) _) indexLeft depthLeft = depthLeftAndTypeAt le (indexLeft - 1) (depthLeft - 1)
 depthLeftAndTypeAtR (TR _ Nothing _) indexLeft depthLeft = undefined
 
@@ -459,41 +458,10 @@ toLambdaExpressionShort (TR _ (Nothing) _) = "Invalid Lambda Epr"
 
 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 (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))
-
-
-meanOfAccuricyPerClass :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
-meanOfAccuricyPerClass results = mean $ map (accuracyInClass results) [minBound .. maxBound]
-
-geomeanOfAccuricyPerClass :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
-geomeanOfAccuricyPerClass results = geomean $ map (accuracyInClass results) [minBound .. maxBound]
-
-geomeanOfDistributionAccuracy :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
-geomeanOfDistributionAccuracy results = geomean $ map (distributionAccuracyForClass results) [minBound .. maxBound]
-
-distributionAccuracyForClass :: (Eq r) => [(r, r)] -> r -> R
-distributionAccuracyForClass results clas = (1 - (min 1 (fromIntegral (abs ((length (inResClass results clas)) - (length (inClass results clas)))) / fromIntegral (length (inClass results clas))))) * 100
-
-mean :: (Show f, Floating f) => [f] -> f
-mean values = (sum values) * (1 / (fromIntegral (length values)))
-
-geomean :: (Show f, Floating f) => [f] -> f
-geomean values = (product values) ** (1 / (fromIntegral (length values)))
-
-accuracyInClass :: (Eq r) => [(r, r)] -> r -> R
-accuracyInClass results clas = ((accuracy'(inResClass results clas)) * 100) / fromIntegral (length (inClass results clas))
-
-inClass :: (Eq r) => [(r, r)] -> r -> [(r, r)]
-inClass results clas = (filter ((clas ==) . fst) results)
-
-inResClass :: (Eq r) => [(r, r)] -> r -> [(r, r)]
-inResClass results clas = (filter ((clas ==) . snd) results)
-
-accuracy' :: (Eq r) => [(r, r)] -> R
-accuracy' results = fromIntegral $ length (filter (\(target, res) -> (res == target)) results)

src/Main.hs

@@ -8,8 +8,7 @@ import Pretty
 import Protolude hiding (for)
 import System.IO
 -- import Szenario212Pun
--- import Szenario191
+import Szenario191
-import IrisDataset
 
 data Options = Options
   { iterations :: !N,
@@ -32,7 +31,7 @@ options =
       ( long "population-size"
           <> short 'p'
           <> metavar "N"
-          <> value 50
+          <> value 1000
           <> help "Population size"
       )
 
@@ -49,18 +48,16 @@ main :: IO ()
 main =
   execParser optionsWithHelp >>= \opts -> do
     hSetBuffering stdout NoBuffering
-    let env = irisLE
+    let env = AssignmentEnviroment (students prios, topics prios)
-    let selType = Tournament 3
+    let selType = Tournament 20
-    let run' = run irisLEE env selType 40 (5 / 100) (populationSize opts) (steps (iterations opts))
+    let run' = run prios env selType 20 (5 / 100) (populationSize opts) (steps (iterations opts)) :: Producer (Int, R) IO (Population Assignment)
     pop' <-
       runEffect (for run' logCsv)
-
+    let (res, _) = bests prios 5 pop'
-    irisLE <- calc irisLEE  pop'
+    mapM_ format res
-    let (res, _) = bests irisLE 5 pop'
-    mapM_ (format irisLE) res
   where
-    format irisL s = do
+    format s = do
-      let f = fitness' irisL s
+      let f = fitness prios s
       putErrText $ show f <> "\n" <> pretty s
     logCsv = putText . csv
     csv (t, f) = show t <> " " <> show f

src/Seminar.hs

@@ -159,8 +159,8 @@ prioOf' p (Just _) Nothing = lowestPriority p + 2
 prioOf' p Nothing (Just _) = lowestPriority p + 2
 prioOf' p (Just s) (Just t) = prioOf p s t
 
-instance Evaluator Assignment Priorities R where
+instance Evaluator Assignment Priorities where
-  fitness' prio assment =
+  fitness prio assment =
     negate . sum $ fromIntegral . uncurry (prioOf' prio) <$> assment
 
 -- |