WIP evaluation of Lamda Individuals

This commit is contained in:
Johannes Merl 2024-02-26 13:28:51 +01:00
parent aea502ad64
commit a4012804fb
3 changed files with 97 additions and 42 deletions

View File

@ -21,21 +21,24 @@ build-type: Simple
library library
build-depends: base build-depends: base
, bytestring
, cassava , cassava
, containers , containers
, extra , extra
, MonadRandom , hint
, monad-loops , monad-loops
, MonadRandom
, mwc-random
, optparse-applicative , optparse-applicative
, path
, pipes , pipes
, primitive
, protolude , protolude
, QuickCheck , QuickCheck
, quickcheck-instances , quickcheck-instances
, random , random
, random-fu , random-fu
, random-shuffle , random-shuffle
, mwc-random
, primitive
, text , text
, wl-pprint-text , wl-pprint-text
default-language: Haskell2010 default-language: Haskell2010
@ -49,21 +52,24 @@ library
executable haga executable haga
build-depends: base build-depends: base
, bytestring
, cassava , cassava
, containers , containers
, extra , extra
, MonadRandom , hint
, monad-loops , monad-loops
, MonadRandom
, mwc-random
, optparse-applicative , optparse-applicative
, path
, pipes , pipes
, primitive
, protolude , protolude
, QuickCheck , QuickCheck
, quickcheck-instances , quickcheck-instances
, random , random
, random-fu , random-fu
, random-shuffle , random-shuffle
, mwc-random
, primitive
, text , text
, wl-pprint-text , wl-pprint-text
default-language: Haskell2010 default-language: Haskell2010
@ -78,22 +84,25 @@ executable haga
executable haga-test executable haga-test
build-depends: base build-depends: base
, bytestring
, Cabal
, cassava , cassava
, containers , containers
, Cabal
, extra , extra
, MonadRandom , hint
, monad-loops , monad-loops
, MonadRandom
, mwc-random
, optparse-applicative , optparse-applicative
, path
, pipes , pipes
, primitive
, protolude , protolude
, QuickCheck , QuickCheck
, quickcheck-instances , quickcheck-instances
, random , random
, random-fu , random-fu
, random-shuffle , random-shuffle
, mwc-random
, primitive
, text , text
, wl-pprint-text , wl-pprint-text
default-language: Haskell2010 default-language: Haskell2010

View File

@ -19,10 +19,11 @@
-- In order to use it for a certain problem, basically, you have to make your -- 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' -- solution type an instance of 'Individual' and then simply call the 'run'
-- function. -- 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 Control.Arrow hiding (first, second)
import Data.List.NonEmpty ((<|)) import Data.List.NonEmpty ((<|))
import qualified Data.Map.Strict as Map
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import qualified Data.List.NonEmpty.Extra as NE (appendl) import qualified Data.List.NonEmpty.Extra as NE (appendl)
import Data.Random 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 -- An Evaluator that Individuals of type i can be evaluated by
-- It stores all information required to evaluate an individuals fitness -- 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”. -- An individual's fitness. Higher values are considered “better”.
-- --
@ -89,7 +90,13 @@ class (Eq e, Individual i) => Evaluator i e where
-- 'proportionate1'). -- 'proportionate1').
fitness :: e -> i -> R 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 iParents <- select nParents pop
iChildren <- NE.filter (`notElem` pop) <$> children env nX iParents iChildren <- NE.filter (`notElem` pop) <$> children env nX iParents
let pop' = pop `NE.appendl` iChildren let pop' = pop `NE.appendl` iChildren
-- TODO kinda hacky?!?
eval <- liftIO $ calc eval pop'
let eliteSize = floor . (pElite *) . fromIntegral $ NE.length pop let eliteSize = floor . (pElite *) . fromIntegral $ NE.length pop
let (elitists, rest) = bests eval eliteSize pop' let (elitists, rest) = bests eval eliteSize pop'
case rest of case rest of

View File

@ -15,6 +15,9 @@ import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Maybe import Data.Maybe
import Data.Random import Data.Random
import qualified Data.ByteString.Lazy as B
import Data.Csv
import Data.Proxy
import qualified Data.Text as T import qualified Data.Text as T
import Data.Typeable import Data.Typeable
import GA import GA
@ -23,6 +26,7 @@ import Protolude
import Test.QuickCheck hiding (sample, shuffle) import Test.QuickCheck hiding (sample, shuffle)
import Test.QuickCheck.Monadic (assert, monadicIO) import Test.QuickCheck.Monadic (assert, monadicIO)
import qualified Type.Reflection as Ref import qualified Type.Reflection as Ref
import qualified Language.Haskell.Interpreter as Hint
data ExpressionWeights = ExpressionWeights data ExpressionWeights = ExpressionWeights
{ lambdaSpucker :: Int, { lambdaSpucker :: Int,
@ -40,6 +44,18 @@ data LambdaEnviroment = LambdaEnviroment
weights :: ExpressionWeights 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:: Show a => a -> Text
showSanifid var = T.replace " -> " "To" (show var) 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 -- 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 :: LambdaExpression -> [TypeRequester]
asList (LambdaSpucker tr1 tr2 _) = [tr1, tr2] 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 :: TypeRequester -> Text
toLambdaExpressionS (TR typeRep (Just lambdaExpression) boundVars) = "((" <> eToLambdaExpressionS lambdaExpression <> ") :: (" <> show typeRep <> "))" toLambdaExpressionS (TR typeRep (Just lambdaExpression) boundVars) = "((" <> eToLambdaExpressionS lambdaExpression <> ") :: (" <> show typeRep <> "))"
@ -226,6 +242,7 @@ genLambdaVar' tr varType varNumber trs env@(LambdaEnviroment functions constants
ret <- genLambdaVar' rest varType varNumber (trs ++ [newTypeRequ]) env depthLeft target boundVar ret <- genLambdaVar' rest varType varNumber (trs ++ [newTypeRequ]) env depthLeft target boundVar
return ret return ret
instance Environment TypeRequester LambdaEnviroment where instance Environment TypeRequester LambdaEnviroment where
new env@(LambdaEnviroment _ _ target maxDepth _) = do new env@(LambdaEnviroment _ _ target maxDepth _) = do
tr <- genTypeRequester env maxDepth target [] tr <- genTypeRequester env maxDepth target []
@ -239,35 +256,55 @@ mutate env@(LambdaEnviroment _ _ _ maxDepth _) tr = do
return $ replaceAtR selectedTR tr res return $ replaceAtR selectedTR tr res
crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do
let trCount = countTrsR tr1 return Nothing
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
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 -- helper
findIndicesWhere:: TypeRequester -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)] --findIndicesWhere:: TypeRequester -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)]
findIndicesWhere tr@(TR t lE _) filte indx = case lE of --findIndicesWhere tr@(TR t lE _) filte indx = case lE of
Just le -> (tr, indx+1):(findIndicesWhere' (asList le) filte (indx+1)) -- Just le -> (tr, indx+1):(findIndicesWhere' (asList le) filte (indx+1))
Nothing -> undefined -- Nothing -> undefined
findIndicesWhere':: [TypeRequester] -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)] --findIndicesWhere':: [TypeRequester] -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)]
findIndicesWhere' (tr:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr)) --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:: Int -> TypeRequester -> TypeRequester -> TypeRequester
replaceAtR 0 _ with = with replaceAtR 0 _ with = with
replaceAtR i (TR tm (Just le) bV) with = TR tm (Just (replaceAt (i-1) le with)) bV replaceAtR i (TR tm (Just le) bV) with = TR tm (Just (replaceAt (i-1) le with)) bV