diff --git a/haga.cabal b/haga.cabal index 6076d99..74b1ed2 100644 --- a/haga.cabal +++ b/haga.cabal @@ -30,6 +30,7 @@ library , MonadRandom , mwc-random , optparse-applicative + , parallel , path , pipes , primitive @@ -63,6 +64,7 @@ executable haga , MonadRandom , mwc-random , optparse-applicative + , parallel , path , pipes , primitive @@ -99,6 +101,7 @@ executable haga-test , MonadRandom , mwc-random , optparse-applicative + , parallel , path , pipes , primitive diff --git a/src/Main.hs b/src/Main.hs index b97baa4..f1cdbff 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -26,7 +26,7 @@ options = ( long "iterations" <> short 'i' <> metavar "N" - <> value 1000 + <> value 100 <> help "Number of iterations" ) <*> option @@ -34,7 +34,7 @@ options = ( long "population-size" <> short 'p' <> metavar "N" - <> value 100 + <> value 200 <> help "Population size" ) @@ -54,7 +54,7 @@ main = nurseryLEE <- shuffledNurseryLEE let env = nurseryLE let selType = Tournament 3 - let run' = run nurseryLEE env selType 80 (5 / 100) (populationSize opts) (steps (iterations opts)) + let run' = run nurseryLEE env selType 150 (5 / 100) (populationSize opts) (steps (iterations opts)) pop' <- runEffect (for run' logCsv) nurseryLEE' <- calc nurseryLEE pop' let (res, _) = bests nurseryLEE' 5 pop' diff --git a/src/NurseryDataset.hs b/src/NurseryDataset.hs index a816bcf..f9ea26f 100644 --- a/src/NurseryDataset.hs +++ b/src/NurseryDataset.hs @@ -74,13 +74,13 @@ nurseryLE = ((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 = 8, + maxDepth = 7, weights = ExpressionWeights - { lambdaSpucker = 1, + { lambdaSpucker = 2, lambdaSchlucker = 1, symbol = 30, - variable = 10, + variable = 20, constant = 5 } } @@ -165,23 +165,19 @@ dset :: LamdaExecutionEnv -> ([(Parents, HasNurs, Form, Children, Housing, Finan dset lEE = if training lEE then trainingData lEE else testData lEE evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, FittnesRes)] -evalResults ex trs = mapM (evalResult ex) trs - -evalResult :: LamdaExecutionEnv -> TypeRequester -> Hint.InterpreterT IO (TypeRequester, FittnesRes) -evalResult ex tr = do +evalResults ex trs = do Hint.setImports $ (map T.unpack (imports ex)) ++ ["Protolude"] Hint.unsafeSetGhcOption "-O2" - result <- Hint.interpret (T.unpack (toLambdaExpressionS tr)) (Hint.as :: Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass) - let res = map (\(a, b, c, d, e, f, g, h) -> result a b c d e f g h) (fst (dset ex)) - let resAndTarget = (zip (snd (dset ex)) res) - let acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) / fromIntegral (length resAndTarget) - let biasSmall = exp ((-(fromIntegral (countTrsR tr))) / 1000) -- 0 (schlecht) bis 1 (gut) - let fitness' = meanOfAccuricyPerClass resAndTarget - let score = fitness' + (biasSmall - 1) - return - ( tr, + let arrayOfFunctionText = map toLambdaExpressionS trs + let textOfFunctionArray = "[" <> T.intercalate "," arrayOfFunctionText <> "]" + result <- Hint.interpret (T.unpack (textOfFunctionArray)) (Hint.as :: [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 = score, + { total = acc * 100 + (biasSmall - 1), fitnessTotal = fitness', fitnessMean = meanOfAccuricyPerClass resAndTarget, fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget, @@ -190,6 +186,14 @@ evalResult ex tr = do 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) + if' :: Bool -> a -> a -> a if' True e _ = e diff --git a/src/Utils.hs b/src/Utils.hs index 407afd4..3f6bb50 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -30,7 +30,7 @@ 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)) +accuracyInClass results clas = if fromIntegral (length (inClass results clas)) == 0 then 100 else ((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)