Hans/haga
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

WIP evaluation of Lamda Individuals

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
haga.cabal
View File

@ -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

15
src/GA.hs
View File

@ -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

95
src/LambdaCalculus.hs
View File

@ -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