From a4012804fb24fdb1a50bbec50f56bd4d055b3ba4 Mon Sep 17 00:00:00 2001 From: Johannes Merl Date: Mon, 26 Feb 2024 13:28:51 +0100 Subject: [PATCH] WIP evaluation of Lamda Individuals --- haga.cabal | 29 ++++++++----- src/GA.hs | 15 +++++-- src/LambdaCalculus.hs | 95 ++++++++++++++++++++++++++++++------------- 3 files changed, 97 insertions(+), 42 deletions(-) diff --git a/haga.cabal b/haga.cabal index a402668..9108a6a 100644 --- a/haga.cabal +++ b/haga.cabal @@ -21,21 +21,24 @@ build-type: Simple library build-depends: base + , bytestring , cassava , containers , extra - , MonadRandom + , hint , monad-loops + , MonadRandom + , mwc-random , optparse-applicative + , path , pipes + , primitive , protolude , QuickCheck , quickcheck-instances , random , random-fu , random-shuffle - , mwc-random - , primitive , text , wl-pprint-text default-language: Haskell2010 @@ -49,21 +52,24 @@ library executable haga build-depends: base + , bytestring , cassava , containers , extra - , MonadRandom + , hint , monad-loops + , MonadRandom + , mwc-random , optparse-applicative + , path , pipes + , primitive , protolude , QuickCheck , quickcheck-instances , random , random-fu , random-shuffle - , mwc-random - , primitive , text , wl-pprint-text default-language: Haskell2010 @@ -78,22 +84,25 @@ executable haga executable haga-test build-depends: base + , bytestring + , Cabal , cassava , containers - , Cabal , extra - , MonadRandom + , hint , monad-loops + , MonadRandom + , mwc-random , optparse-applicative + , path , pipes + , primitive , protolude , QuickCheck , quickcheck-instances , random , random-fu , random-shuffle - , mwc-random - , primitive , text , wl-pprint-text default-language: Haskell2010 diff --git a/src/GA.hs b/src/GA.hs index 441b210..4f7c4e1 100644 --- a/src/GA.hs +++ b/src/GA.hs @@ -19,10 +19,11 @@ -- 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, Evaluator, fitness, Individual, GA.run, tournament, N, R, Population, steps, bests, runTests) where +module GA ( Environment,new, population, mutate, crossover1,crossover, Evaluator, 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.Map.Strict as Map import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty.Extra as NE (appendl) import Data.Random @@ -81,7 +82,7 @@ class (Pretty e, Individual i) => Environment 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 (Eq e, Individual i) => Evaluator i e where +class (Individual i) => Evaluator i e where -- | -- An individual's fitness. Higher values are considered “better”. -- @@ -89,7 +90,13 @@ class (Eq e, Individual i) => Evaluator i e where -- 'proportionate1'). fitness :: e -> i -> R -class (Pretty i, Eq i) => Individual i + -- TODO kinda hacky?!? + calc :: e -> Population i -> IO e + calc eval _ = do + return eval + + +class (Pretty i, Ord i) => Individual i @@ -183,6 +190,8 @@ stepSteady eval env select nParents nX pElite pop = do iParents <- select nParents pop iChildren <- NE.filter (`notElem` pop) <$> children env nX iParents let pop' = pop `NE.appendl` iChildren + -- TODO kinda hacky?!? + eval <- liftIO $ calc eval pop' let eliteSize = floor . (pElite *) . fromIntegral $ NE.length pop let (elitists, rest) = bests eval eliteSize pop' case rest of diff --git a/src/LambdaCalculus.hs b/src/LambdaCalculus.hs index fba977d..4419d87 100644 --- a/src/LambdaCalculus.hs +++ b/src/LambdaCalculus.hs @@ -15,6 +15,9 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe import Data.Random +import qualified Data.ByteString.Lazy as B +import Data.Csv +import Data.Proxy import qualified Data.Text as T import Data.Typeable import GA @@ -23,6 +26,7 @@ import Protolude import Test.QuickCheck hiding (sample, shuffle) import Test.QuickCheck.Monadic (assert, monadicIO) import qualified Type.Reflection as Ref +import qualified Language.Haskell.Interpreter as Hint data ExpressionWeights = ExpressionWeights { lambdaSpucker :: Int, @@ -40,6 +44,18 @@ data LambdaEnviroment = LambdaEnviroment weights :: ExpressionWeights } +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, + exTargetType :: TypeRep, + -- todo: kindaHacky + results :: Map TypeRequester R + } + showSanifid:: Show a => a -> Text showSanifid var = T.replace " -> " "To" (show var) @@ -76,7 +92,7 @@ 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) +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] @@ -87,7 +103,7 @@ asList (Constan _) = [] -data TypeRequester = TR TypeRep (Maybe LambdaExpression) BoundVars deriving (Eq) +data TypeRequester = TR TypeRep (Maybe LambdaExpression) BoundVars deriving (Eq, Ord) toLambdaExpressionS :: TypeRequester -> Text toLambdaExpressionS (TR typeRep (Just lambdaExpression) boundVars) = "((" <> eToLambdaExpressionS lambdaExpression <> ") :: (" <> show typeRep <> "))" @@ -226,48 +242,69 @@ genLambdaVar' tr varType varNumber trs env@(LambdaEnviroment functions constants 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 + new env@(LambdaEnviroment _ _ target maxDepth _) = do + tr <- genTypeRequester env maxDepth target [] + return tr -mutate env@(LambdaEnviroment _ _ _ maxDepth _) tr = 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 + mutate env@(LambdaEnviroment _ _ _ maxDepth _) tr = 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 -crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do - let trCount = countTrsR tr1 - selectedIndex1 <- uniform 1 trCount - let (depthAt, selectedTr1@(TR trep _ bound)) = depthLeftAndTypeAtR tr selectedTR maxDepth - let indexes = findIndicesWhere tr2 ( == trep) - if length indexes == 0 then return Nothing else (do - (selectedTr2,selectedIndex2) <- randomElement indexes + crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do + return Nothing +instance Evaluator TypeRequester LamdaExecutionEnv where + fitness env tr = (results env) Map.! tr + calc env pop = do + let toAdd = NE.filter (\k -> Map.member k (results env) ) pop + let insertPair (key, val) m = Map.insert key val m + toInsert <- Hint.runInterpreter (evalResults env toAdd) + let res = foldr insertPair (results env) (fromRight undefined toInsert) + return env {results = res} +-- let trCount = countTrsR tr1 +-- selectedIndex1 <- uniform 1 trCount +-- let (depthAt, selectedTr1@(TR trep _ bound)) = depthLeftAndTypeAtR tr selectedTR maxDepth +-- let indexes = findIndicesWhere tr2 ( == trep) +-- if length indexes == 0 then return Nothing else (do +-- (selectedTr2,selectedIndex2) <- randomElement indexes) - ) +evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, R)] +evalResults ex trs = mapM (evalResult ex) trs + +data IrisClass = Setosa | Virginica | Versicolor + +evalResult :: LamdaExecutionEnv -> TypeRequester -> Hint.InterpreterT IO (TypeRequester, R) +evalResult ex tr = do + Hint.loadModules (map show (imports ex)) + result <- Hint.interpret (show (toLambdaExpressionS tr)) (Hint.as ::R -> R -> R -> IrisClass) + csv <- liftIO $ B.readFile (trainingDataset ex) + let recs = toList $ fromRight undefined $ decode NoHeader csv + let res = map (show (uncurry result)) recs + csvRes <- liftIO $ B.readFile (trainingDatasetRes ex) + let recsRes = toList $ fromRight undefined $ decode NoHeader csvRes + let score = (foldr (\ts s -> if fst ts == snd ts then s + 1 else s - 1) 0 (zip recsRes res)) :: R + return (tr, score) -- helper -findIndicesWhere:: TypeRequester -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)] -findIndicesWhere tr@(TR t lE _) filte indx = case lE of - Just le -> (tr, indx+1):(findIndicesWhere' (asList le) filte (indx+1)) - Nothing -> undefined +--findIndicesWhere:: TypeRequester -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)] +--findIndicesWhere tr@(TR t lE _) filte indx = case lE of +-- Just le -> (tr, indx+1):(findIndicesWhere' (asList le) filte (indx+1)) +-- Nothing -> undefined -findIndicesWhere':: [TypeRequester] -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)] -findIndicesWhere' (tr:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr)) +--findIndicesWhere':: [TypeRequester] -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)] +--findIndicesWhere' (tr:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr)) -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 = undefined - replaceAtR:: Int -> TypeRequester -> TypeRequester -> TypeRequester replaceAtR 0 _ with = with replaceAtR i (TR tm (Just le) bV) with = TR tm (Just (replaceAt (i-1) le with)) bV