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

LamdaCalculusV2

Browse Source
This commit is contained in:
Johannes Merl 2024-05-07 14:58:00 +02:00
parent d5fe65ab8c
commit 17b64f263b
10 changed files with 676 additions and 13189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
haga.cabal
View File

@ -40,6 +40,7 @@ library
, random , random
, random-fu , random-fu
, random-shuffle , random-shuffle
, semirings
, text , text
, wl-pprint-text , wl-pprint-text
default-language: Haskell2010 default-language: Haskell2010
@ -48,6 +49,7 @@ library
other-modules: CommonDefinition other-modules: CommonDefinition
exposed-modules: GA exposed-modules: GA
, LambdaCalculus , LambdaCalculus
, LambdaCalculusV2
, Pretty , Pretty
, Utils , Utils
, LambdaDatasets.NurseryDefinition , LambdaDatasets.NurseryDefinition

10
lambda/lib/LambdaDatasets/NurseryDefinition.hs
View File

@ -13,20 +13,28 @@ import Protolude
import CommonDefinition import CommonDefinition
data NurseryClass = NotRecommend | Recommend | VeryRecommend | Priority | SpecPriority deriving (Eq, Generic, Show, Enum, Bounded, Ord) data NurseryClass = NotRecommend | Recommend | VeryRecommend | Priority | SpecPriority deriving (Eq, Generic, Show, Enum, Bounded, Ord)
instance Hashable NurseryClass
data Parents = Usual | Pretentious | GreatPret deriving (Eq, Generic, Show, Enum, Bounded, Ord) data Parents = Usual | Pretentious | GreatPret deriving (Eq, Generic, Show, Enum, Bounded, Ord)
instance Hashable Parents
data HasNurs = ProperNurs | LessProperNurs | ImproperNurs | CriticalNurs | VeryCritNurs deriving (Eq, Generic, Show, Enum, Bounded, Ord) data HasNurs = ProperNurs | LessProperNurs | ImproperNurs | CriticalNurs | VeryCritNurs deriving (Eq, Generic, Show, Enum, Bounded, Ord)
instance Hashable HasNurs
data Form = CompleteFamilyForm | CompletedFamilyForm | IncompleteFamilyForm | FosterFamilyForm deriving (Eq, Generic, Show, Enum, Bounded, Ord) data Form = CompleteFamilyForm | CompletedFamilyForm | IncompleteFamilyForm | FosterFamilyForm deriving (Eq, Generic, Show, Enum, Bounded, Ord)
instance Hashable Form
data Children = OneChild | TwoChilds | ThreeChilds | MoreChilds deriving (Eq, Generic, Show, Enum, Bounded, Ord) data Children = OneChild | TwoChilds | ThreeChilds | MoreChilds deriving (Eq, Generic, Show, Enum, Bounded, Ord)
instance Hashable Children
data Housing = ConvenientHousing | LessConvHousing | CriticalHousing deriving (Eq, Generic, Show, Enum, Bounded, Ord) data Housing = ConvenientHousing | LessConvHousing | CriticalHousing deriving (Eq, Generic, Show, Enum, Bounded, Ord)
instance Hashable Housing
data Finance = ConvenientFinance | InconvFinance deriving (Eq, Generic, Show, Enum, Bounded, Ord) data Finance = ConvenientFinance | InconvFinance deriving (Eq, Generic, Show, Enum, Bounded, Ord)
instance Hashable Finance
data Social = NotProblematicSocial | SlightlyProblematicSocial | ProblematicSocial deriving (Eq, Generic, Show, Enum, Bounded, Ord) data Social = NotProblematicSocial | SlightlyProblematicSocial | ProblematicSocial deriving (Eq, Generic, Show, Enum, Bounded, Ord)
instance Hashable Social
data Health = NotRecommendHealth |RecommendedHealth | PriorityHealth deriving (Eq, Generic, Show, Enum, Bounded, Ord) data Health = NotRecommendHealth |RecommendedHealth | PriorityHealth deriving (Eq, Generic, Show, Enum, Bounded, Ord)
instance Hashable Health

12975
lambda/src/LambdaDatasets/NurseryData.hs
View File

File diff suppressed because one or more lines are too long

238
lambda/src/LambdaDatasets/NurseryDataset.hs
View File

@ -5,7 +5,7 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
module LambdaDatasets.NurseryDataset module LambdaDatasets.NurseryDataset
( module LambdaCalculus, ( module LambdaCalculusV2,
module LambdaDatasets.NurseryDataset, module LambdaDatasets.NurseryDataset,
module LambdaDatasets.NurseryData, module LambdaDatasets.NurseryData,
module GA, module GA,
@ -19,8 +19,8 @@ import Data.Random.Distribution.Uniform
import qualified Data.Text as T import qualified Data.Text as T
import Data.Tuple.Extra import Data.Tuple.Extra
import GA import GA
import LambdaCalculusV2
import LambdaDatasets.NurseryData import LambdaDatasets.NurseryData
import LambdaCalculus
import qualified Language.Haskell.Interpreter as Hint import qualified Language.Haskell.Interpreter as Hint
import qualified Language.Haskell.Interpreter.Unsafe as Hint import qualified Language.Haskell.Interpreter.Unsafe as Hint
import Protolude import Protolude
@ -29,171 +29,111 @@ import System.Random.MWC (createSystemRandom)
import qualified Type.Reflection as Ref import qualified Type.Reflection as Ref
import Utils import Utils
lE :: LambdaEnviroment operators :: [BoundSymbol]
lE = operators = [ -- Math
LambdaEnviroment
{ functions =
Map.fromList
[ -- Math
-- Logic -- Logic
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]), BoundSymbol (Ref.TypeRep @(Bool -> Bool -> Bool)) (&&) (Just "(&&)"),
BoundSymbol (Ref.TypeRep @(Bool -> Bool -> Bool)) (||) (Just "(||)"),
-- Ordered Enums -- Ordered Enums
((Ref.SomeTypeRep (Ref.TypeRep @(NurseryClass -> NurseryClass -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]), BoundSymbol (Ref.TypeRep @(NurseryClass -> NurseryClass -> Bool)) (>) (Just "(>)"),
((Ref.SomeTypeRep (Ref.TypeRep @(Parents -> Parents -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]), BoundSymbol (Ref.TypeRep @(NurseryClass -> NurseryClass -> Bool)) (==) (Just "(==)"),
((Ref.SomeTypeRep (Ref.TypeRep @(HasNurs -> HasNurs -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]), BoundSymbol (Ref.TypeRep @(NurseryClass -> NurseryClass -> Bool)) (/=) (Just "(/=)"),
((Ref.SomeTypeRep (Ref.TypeRep @(Form -> Form -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]), BoundSymbol (Ref.TypeRep @(NurseryClass -> NurseryClass -> Bool)) (>=) (Just "(>=)"),
((Ref.SomeTypeRep (Ref.TypeRep @(Children -> Children -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]), BoundSymbol (Ref.TypeRep @(Parents -> Parents -> Bool)) (>) (Just "(>)"),
((Ref.SomeTypeRep (Ref.TypeRep @(Housing -> Housing -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]), BoundSymbol (Ref.TypeRep @(Parents -> Parents -> Bool)) (==) (Just "(==)"),
((Ref.SomeTypeRep (Ref.TypeRep @(Finance -> Finance -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]), BoundSymbol (Ref.TypeRep @(Parents -> Parents -> Bool)) (/=) (Just "(/=)"),
((Ref.SomeTypeRep (Ref.TypeRep @(Social -> Social -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]), BoundSymbol (Ref.TypeRep @(Parents -> Parents -> Bool)) (>=) (Just "(>=)"),
((Ref.SomeTypeRep (Ref.TypeRep @(Health -> Health -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]), BoundSymbol (Ref.TypeRep @(HasNurs -> HasNurs -> Bool)) (>) (Just "(>)"),
BoundSymbol (Ref.TypeRep @(HasNurs -> HasNurs -> Bool)) (==) (Just "(==)"),
BoundSymbol (Ref.TypeRep @(HasNurs -> HasNurs -> Bool)) (/=) (Just "(/=)"),
BoundSymbol (Ref.TypeRep @(HasNurs -> HasNurs -> Bool)) (>=) (Just "(>=)"),
BoundSymbol (Ref.TypeRep @(Form -> Form -> Bool)) (>) (Just "(>)"),
BoundSymbol (Ref.TypeRep @(Form -> Form -> Bool)) (==) (Just "(==)"),
BoundSymbol (Ref.TypeRep @(Form -> Form -> Bool)) (/=) (Just "(/=)"),
BoundSymbol (Ref.TypeRep @(Form -> Form -> Bool)) (>=) (Just "(>=)"),
BoundSymbol (Ref.TypeRep @(Children -> Children -> Bool)) (>) (Just "(>)"),
BoundSymbol (Ref.TypeRep @(Children -> Children -> Bool)) (==) (Just "(==)"),
BoundSymbol (Ref.TypeRep @(Children -> Children -> Bool)) (/=) (Just "(/=)"),
BoundSymbol (Ref.TypeRep @(Children -> Children -> Bool)) (>=) (Just "(>=)"),
BoundSymbol (Ref.TypeRep @(Housing -> Housing -> Bool)) (>) (Just "(>)"),
BoundSymbol (Ref.TypeRep @(Housing -> Housing -> Bool)) (==) (Just "(==)"),
BoundSymbol (Ref.TypeRep @(Housing -> Housing -> Bool)) (/=) (Just "(/=)"),
BoundSymbol (Ref.TypeRep @(Housing -> Housing -> Bool)) (>=) (Just "(>=)"),
BoundSymbol (Ref.TypeRep @(Finance -> Finance -> Bool)) (>) (Just "(>)"),
BoundSymbol (Ref.TypeRep @(Finance -> Finance -> Bool)) (==) (Just "(==)"),
BoundSymbol (Ref.TypeRep @(Finance -> Finance -> Bool)) (/=) (Just "(/=)"),
BoundSymbol (Ref.TypeRep @(Finance -> Finance -> Bool)) (>=) (Just "(>=)"),
BoundSymbol (Ref.TypeRep @(Social -> Social -> Bool)) (>) (Just "(>)"),
BoundSymbol (Ref.TypeRep @(Social -> Social -> Bool)) (==) (Just "(==)"),
BoundSymbol (Ref.TypeRep @(Social -> Social -> Bool)) (/=) (Just "(/=)"),
BoundSymbol (Ref.TypeRep @(Social -> Social -> Bool)) (>=) (Just "(>=)"),
BoundSymbol (Ref.TypeRep @(Health -> Health -> Bool)) (>) (Just "(>)"),
BoundSymbol (Ref.TypeRep @(Health -> Health -> Bool)) (==) (Just "(==)"),
BoundSymbol (Ref.TypeRep @(Health -> Health -> Bool)) (/=) (Just "(/=)"),
BoundSymbol (Ref.TypeRep @(Health -> Health -> Bool)) (>=) (Just "(>=)"),
-- Eq Enum -- Eq Enum
-- Any Type -- Any Type
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Int -> Int -> Int))), ["if'"]), BoundSymbol (Ref.TypeRep @(Bool -> Int -> Int -> Int)) (if') (Just "if'"),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> NurseryClass -> NurseryClass -> NurseryClass))), ["if'","if'","if'","if'","if'","if'","if'","if'"]), BoundSymbol (Ref.TypeRep @(Bool -> NurseryClass -> NurseryClass -> NurseryClass)) (if') (Just "if'"),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Parents -> Parents -> Parents))), ["if'"]), BoundSymbol (Ref.TypeRep @(Bool -> Parents -> Parents -> Parents)) (if') (Just "if'"),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> HasNurs -> HasNurs -> HasNurs))), ["if'"]), BoundSymbol (Ref.TypeRep @(Bool -> HasNurs -> HasNurs -> HasNurs)) (if') (Just "if'"),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Form -> Form -> Form))), ["if'"]), BoundSymbol (Ref.TypeRep @(Bool -> Form -> Form -> Form)) (if') (Just "if'"),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Children -> Children -> Children))), ["if'"]), BoundSymbol (Ref.TypeRep @(Bool -> Children -> Children -> Children)) (if') (Just "if'"),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Housing -> Housing -> Housing))), ["if'"]), BoundSymbol (Ref.TypeRep @(Bool -> Housing -> Housing -> Housing)) (if') (Just "if'"),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Finance -> Finance -> Finance))), ["if'"]), BoundSymbol (Ref.TypeRep @(Bool -> Finance -> Finance -> Finance)) (if') (Just "if'"),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Social -> Social -> Social))), ["if'"]), BoundSymbol (Ref.TypeRep @(Bool -> Social -> Social -> Social)) (if') (Just "if'"),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Health -> Health -> Health))), ["if'"]) BoundSymbol (Ref.TypeRep @(Bool -> Health -> Health -> Health)) (if') (Just "if'")
], ]
lE :: LambdaEnviroment (Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass)
lE =
LambdaEnviroment
{ functions = operators,
constants = constants =
Map.fromList [ ConstVal (Ref.TypeRep @(Bool)) (uniform True False),
[ ((Ref.SomeTypeRep (Ref.TypeRep @(Bool))), [(fmap show (uniform True False :: RVar Bool))]), ConstVal (Ref.TypeRep @(NurseryClass)) (enumUniform NotRecommend SpecPriority),
((Ref.SomeTypeRep (Ref.TypeRep @(NurseryClass))), [(fmap show (enumUniform NotRecommend SpecPriority))]), ConstVal (Ref.TypeRep @(Parents)) (enumUniform Usual GreatPret),
((Ref.SomeTypeRep (Ref.TypeRep @(Parents))), [(fmap show (enumUniform Usual GreatPret))]), ConstVal (Ref.TypeRep @(HasNurs)) (enumUniform ProperNurs VeryCritNurs),
((Ref.SomeTypeRep (Ref.TypeRep @(HasNurs))), [(fmap show (enumUniform ProperNurs VeryCritNurs ))]), ConstVal (Ref.TypeRep @(Form)) (enumUniform CompleteFamilyForm FosterFamilyForm),
((Ref.SomeTypeRep (Ref.TypeRep @(Form))), [(fmap show (enumUniform CompleteFamilyForm FosterFamilyForm ))]), ConstVal (Ref.TypeRep @(Children)) (enumUniform OneChild MoreChilds),
((Ref.SomeTypeRep (Ref.TypeRep @(Children))), [(fmap show (enumUniform OneChild MoreChilds ))]), ConstVal (Ref.TypeRep @(Housing)) (enumUniform ConvenientHousing CriticalHousing),
((Ref.SomeTypeRep (Ref.TypeRep @(Housing))), [(fmap show (enumUniform ConvenientHousing CriticalHousing ))]), ConstVal (Ref.TypeRep @(Finance)) (enumUniform ConvenientFinance InconvFinance),
((Ref.SomeTypeRep (Ref.TypeRep @(Finance))), [(fmap show (enumUniform ConvenientFinance InconvFinance ))]), ConstVal (Ref.TypeRep @(Social)) (enumUniform NotProblematicSocial ProblematicSocial),
((Ref.SomeTypeRep (Ref.TypeRep @(Social))), [(fmap show (enumUniform NotProblematicSocial ProblematicSocial ))]), ConstVal (Ref.TypeRep @(Health)) (enumUniform NotRecommendHealth PriorityHealth)
((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 = 150,
maxDepth = 8,
weights = weights =
ExpressionWeights ExpressionWeights
{ lambdaSpucker = 1, { application = 2,
lambdaSchlucker = 2, abstraction = 2,
symbol = 30, variableReference = 300,
variable = 20, constant = 1,
constant = 5 functionBias = 100
} },
mutationStrength = 10/150,
crossoverStrength = 15/150
} }
trainingFraction :: R trainingFraction :: R
trainingFraction = (2/3) trainingFraction = (2 / 3)
lEE :: LamdaExecutionEnv lEE :: ExecutionEnviroment (Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass)
lEE = lEE =
LamdaExecutionEnv ExecutionEnviroment
{ -- For now these need to define all available functions and types. Generic functions can be used. { -- For now these need to define all available functions and types. Generic functions can be used.
imports = ["LambdaDatasets.NurseryDefinition"], fun = operators,
training = True, training = True,
trainingData = trainingData = nurseryTrainingData,
( map fst (takeFraktion trainingFraction nurseryTrainingData), testData = nurseryTrainingData
map snd (takeFraktion trainingFraction nurseryTrainingData)
),
testData =
( map fst (dropFraktion trainingFraction nurseryTrainingData),
map snd (dropFraktion trainingFraction nurseryTrainingData)
),
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass))),
results = Map.empty
} }
shuffledLEE :: IO LamdaExecutionEnv shuffledLEE :: IO (ExecutionEnviroment (Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass))
shuffledLEE = do shuffledLEE = do
mwc <- liftIO createSystemRandom
let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
itD <- smpl $ shuffle nurseryTrainingData
return return
LamdaExecutionEnv ExecutionEnviroment
{ -- For now these need to define all available functions and types. Generic functions can be used. { fun = operators,
imports = ["LambdaDatasets.NurseryDefinition"],
training = True, training = True,
trainingData = trainingData = nurseryTrainingData,
( map fst (takeFraktion trainingFraction itD), testData = nurseryTrainingData
map snd (takeFraktion trainingFraction itD)
),
testData =
( map fst (dropFraktion trainingFraction itD),
map snd (dropFraktion trainingFraction itD)
),
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Parents -> HasNurs -> Form -> Children -> Housing -> Finance -> Social -> Health -> NurseryClass))),
results = Map.empty
} }
data LamdaExecutionEnv = LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports :: [Text],
training :: Bool,
trainingData :: ([(Parents, HasNurs, Form, Children, Housing, Finance, Social, Health)], [NurseryClass]),
testData :: ([(Parents, HasNurs, Form, Children, Housing, Finance, Social, Health)], [NurseryClass]),
exTargetType :: TypeRep,
-- todo: kindaHacky
results :: Map TypeRequester FittnesRes
}
data FittnesRes = FittnesRes
{ total :: R,
fitnessTotal :: R,
fitnessGeoMean :: R,
fitnessMean :: R,
accuracy :: R,
biasSize :: R,
totalSize :: N
}
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 relevantResults = Map.filterWithKey (\k _ -> contains pop k) (results env)
let toAdd = NE.filter (\k -> not (Map.member k relevantResults)) pop
toInsert <- Hint.runInterpreter (evalResults env toAdd)
let insertPair (key, val) m = Map.insert key val m
let res = foldr insertPair relevantResults (fromRight (error ("To insert is " <> show toInsert)) toInsert)
return env {results = res}
dset :: LamdaExecutionEnv -> ([(Parents, HasNurs, Form, Children, Housing, Finance, Social, Health)], [NurseryClass])
dset lEE = if training lEE then trainingData lEE else testData lEE
evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, FittnesRes)]
evalResults ex trs = do
Hint.setImports $ (map T.unpack (imports ex)) ++ ["Protolude"]
Hint.unsafeSetGhcOption "-O2"
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 = acc * 100 + (biasSmall - 1),
fitnessTotal = fitness',
fitnessMean = meanOfAccuricyPerClass resAndTarget,
fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
accuracy = acc,
biasSize = biasSmall,
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)

9
lambda/src/Main.hs
View File

@ -5,7 +5,6 @@
import Options.Applicative import Options.Applicative
import Pipes import Pipes
import Pretty
import Protolude hiding (for) import Protolude hiding (for)
import System.IO import System.IO
-- import LambdaDatasets.IrisDataset -- import LambdaDatasets.IrisDataset
@ -27,7 +26,7 @@ options =
( long "iterations" ( long "iterations"
<> short 'i' <> short 'i'
<> metavar "N" <> metavar "N"
<> value 1500 <> value 1
<> help "Number of iterations" <> help "Number of iterations"
) )
<*> option <*> option
@ -35,7 +34,7 @@ options =
( long "population-size" ( long "population-size"
<> short 'p' <> short 'p'
<> metavar "N" <> metavar "N"
<> value 400 <> value 100
<> help "Population size" <> help "Population size"
) )
@ -59,7 +58,7 @@ main =
selectionType = Tournament 3, selectionType = Tournament 3,
termination = (steps (iterations opts)), termination = (steps (iterations opts)),
poulationSize = (populationSize opts), poulationSize = (populationSize opts),
stepSize = 120, nParents = 120,
elitismRatio = 5/100 elitismRatio = 5/100
} }
pop' <- runEffect (for (run cfg) logCsv) pop' <- runEffect (for (run cfg) logCsv)
@ -71,6 +70,6 @@ main =
where where
format l s = do format l s = do
let f = fitness' l s let f = fitness' l s
putErrText $ show f <> "\n" <> pretty s putErrText $ show f <> "\n" <> output (lE) s
logCsv = putText . csv logCsv = putText . csv
csv (t, f) = show t <> " " <> show f csv (t, f) = show t <> " " <> show f

19
lib/GA.hs
View File

@ -24,7 +24,7 @@
-- 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 (..), Fitness (..), Evaluator (..), Individual (..), GA.run, Tournament (..), N, R, Population, steps, bests, runTests, GaRunConfig (..)) where module GA (Environment (..), Fitness (..), Evaluator (..), Individual, GA.run, Tournament (..), N, R, Population, steps, bests, runTests, GaRunConfig (..)) where
import Control.Arrow hiding (first, second) import Control.Arrow hiding (first, second)
import Data.List.NonEmpty ((<|)) import Data.List.NonEmpty ((<|))
@ -51,7 +51,9 @@ type R = Double
-- | -- |
-- An Environment that Individuals of type i can be created from -- An Environment that Individuals of type i can be created from
-- It stores all information required to create and change Individuals correctly -- It stores all information required to create and change Individuals correctly
class (Pretty e, Individual i) => Environment i e | e -> i, i -> e where class (Individual i) => Environment i e | e -> i, i -> e where
output :: e -> i -> Text
-- | -- |
-- Generates a completely random individual. -- Generates a completely random individual.
new :: e -> RVar i new :: e -> RVar i
@ -88,7 +90,7 @@ class (Pretty e, Individual i) => Environment i e | e -> i, 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 (Individual i, Fitness r) => Evaluator i e r | e -> i r, i -> e where class (Individual i, Fitness r) => Evaluator i e r | e -> i r where
-- | -- |
-- An individual's fitness. Higher values are considered “better”. -- An individual's fitness. Higher values are considered “better”.
-- --
@ -107,10 +109,9 @@ class (Individual i, Fitness r) => Evaluator i e r | e -> i r, i -> e where
-- It is guaranteed that the e passed to fitness is the result of a calc function, where the individual was part of the Population passed. -- It is guaranteed that the e passed to fitness is the result of a calc function, where the individual was part of the Population passed.
-- It may be smart to reuse known results between invocations. -- It may be smart to reuse known results between invocations.
calc :: e -> Population i -> IO e calc :: e -> Population i -> IO e
calc eval _ = do calc eval _ = return eval
return eval
class (Pretty i, Ord i) => Individual i class (Ord i) => Individual i
class (Show i) => Fitness i where class (Show i) => Fitness i where
getR :: i -> R getR :: i -> R
@ -324,18 +325,18 @@ shuffle' :: NonEmpty a -> RVar (NonEmpty a)
shuffle' xs@(_ :| []) = return xs shuffle' xs@(_ :| []) = return xs
shuffle' xs = fmap (NE.fromList) (shuffle (toList xs)) shuffle' xs = fmap (NE.fromList) (shuffle (toList xs))
instance Pretty Integer where
pretty i = "Found int: " <> show i
instance Individual Integer instance Individual Integer
newtype IntTestEnviroment = IntTestEnviroment ((Integer, Integer), Integer, N) deriving (Eq) -- IntTestEnviroment ((0,100000),10) newtype IntTestEnviroment = IntTestEnviroment ((Integer, Integer), Integer, N) deriving (Eq, Show) -- IntTestEnviroment ((0,100000),10)
instance Pretty IntTestEnviroment where instance Pretty IntTestEnviroment where
-- instance Pretty (Maybe Student) where -- instance Pretty (Maybe Student) where
pretty (IntTestEnviroment ((i, j), k, _)) = "IntTestEnviroment of Individuals between " <> (show i) <> " and " <> (show j) <> " variance when mutating is " <> (show k) pretty (IntTestEnviroment ((i, j), k, _)) = "IntTestEnviroment of Individuals between " <> (show i) <> " and " <> (show j) <> " variance when mutating is " <> (show k)
instance Environment Integer IntTestEnviroment where instance Environment Integer IntTestEnviroment where
output _ i = "Found int: " <> show i
new (IntTestEnviroment ((from, to), _, _)) = uniform from to new (IntTestEnviroment ((from, to), _, _)) = uniform from to
nX (IntTestEnviroment ((_, _), _, n)) = n nX (IntTestEnviroment ((_, _), _, n)) = n

552
lib/LambdaCalculusV2.hs
View File

@ -1,48 +1,67 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeAbstractions #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE FlexibleInstances #-}
module LambdaCalculusV2 where module LambdaCalculusV2 where
import qualified Data.Map.Strict as Map
import Data.Kind
import qualified Type.Reflection as Ref
import Data.Dynamic import Data.Dynamic
import Protolude import Data.Kind
import Protolude.Partial import qualified Data.Set as Set
import Protolude.Error import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Random import Data.Random
import Data.Typeable
import Debug.Trace as DB
import qualified Data.Text as T
import GA
import Protolude
import Protolude.Error
import Protolude.Partial
import qualified Type.Reflection as Ref
import Utils
type BoundVars = Map.Map (Ref.SomeTypeRep) [Dynamic] data BoundSymbol where
BoundSymbol :: (Typeable a) => Ref.TypeRep a -> a -> Maybe Text -> BoundSymbol
type Bindings = Map.Map (Ref.SomeTypeRep) Int
data SomeSimplyTypedLambdaExpression where
SomeSimplyTypedLambdaExpression :: (Typeable a) => SimplyTypedLambdaExpression a -> SomeSimplyTypedLambdaExpression
-- We specify a and use GADTs to allow Haskell to guarantee full type safety over these expressions! -- We specify a and use GADTs to allow Haskell to guarantee full type safety over these expressions!
-- This gurantees us that a SimplyTypedLambdaExpression t describes a lambda expression of type a! -- This gurantees us that a SimplyTypedLambdaExpression a describes a lambda expression of type a!
data SimplyTypedLambdaExpression t where data SimplyTypedLambdaExpression t where
Application :: (Typeable a, Typeable b) => SimplyTypedLambdaExpression (a -> b) -> SimplyTypedLambdaExpression a -> SimplyTypedLambdaExpression b -- e = e1 e2 Application :: (Typeable a, Typeable b) => SimplyTypedLambdaExpression (a -> b) -> SimplyTypedLambdaExpression a -> SimplyTypedLambdaExpression b -- e = e1 e2
Abstraction :: Ref.TypeRep a -> SimplyTypedLambdaExpression (b) -> SimplyTypedLambdaExpression (a -> b) -- e = λx:a. e Abstraction :: (Typeable (a -> b), Typeable b) => Ref.TypeRep a -> SimplyTypedLambdaExpression (b) -> SimplyTypedLambdaExpression (a -> b) -- e = λx:a. e
VariableReference :: Typeable a => Ref.TypeRep a -> Int -> SimplyTypedLambdaExpression a -- e = x VariableReference :: (Typeable a) => Ref.TypeRep a -> Int -> SimplyTypedLambdaExpression a -- e = x this Includes predefined function use!
Constant :: (Typeable a, Ord a, Hashable a ) => a -> SimplyTypedLambdaExpression a -- e = c this Includes predefined function use! Constant :: (Typeable a, Ord a, Hashable a, Show a) => a -> SimplyTypedLambdaExpression a -- e = c
instance Eq (SimplyTypedLambdaExpression t) where instance Eq (SimplyTypedLambdaExpression t) where
e1 == e2 = compare e1 e2 == EQ e1 == e2 = compare e1 e2 == EQ
instance Ord (SimplyTypedLambdaExpression t) where instance Ord (SimplyTypedLambdaExpression t) where
compare (Application (stleAtoB1 :: SimplyTypedLambdaExpression (a1->t)) (stleA1 :: SimplyTypedLambdaExpression a1)) (Application (stleAtoB2 :: SimplyTypedLambdaExpression (a2->t)) (stleA2 :: SimplyTypedLambdaExpression a2)) = case eqT @a1 @a2 of compare (Application (stleAtoB1 :: SimplyTypedLambdaExpression (a1 -> t)) (stleA1 :: SimplyTypedLambdaExpression a1)) (Application (stleAtoB2 :: SimplyTypedLambdaExpression (a2 -> t)) (stleA2 :: SimplyTypedLambdaExpression a2)) = case eqT @a1 @a2 of
Just Refl -> (compare stleAtoB1 stleAtoB2) `thenCmp` (compare stleA1 stleA2) Just Refl -> (compare stleAtoB1 stleAtoB2) `thenCmp` (compare stleA1 stleA2)
_ -> compare ( Ref.SomeTypeRep (Ref.TypeRep @a1)) ( Ref.SomeTypeRep (Ref.TypeRep @a2)) _ -> compare (Ref.SomeTypeRep (Ref.TypeRep @a1)) (Ref.SomeTypeRep (Ref.TypeRep @a2))
compare (Abstraction rep1 stle1) (Abstraction rep2 stle2) = (compare rep1 rep2) `thenCmp` (compare stle1 stle2) compare (Abstraction rep1 stle1) (Abstraction rep2 stle2) = (compare rep1 rep2) `thenCmp` (compare stle1 stle2)
compare (VariableReference repA inx1) (VariableReference repB inx2) = (compare repA repB) `thenCmp` (compare inx1 inx2) compare (VariableReference repA inx1) (VariableReference repB inx2) = (compare repA repB) `thenCmp` (compare inx1 inx2)
compare (Constant res1) (Constant res2) = compare res1 res2 compare (Constant res1) (Constant res2) = compare res1 res2
@ -63,30 +82,497 @@ thenCmp :: Ordering -> Ordering -> Ordering
thenCmp EQ o2 = o2 thenCmp EQ o2 = o2
thenCmp o1 _ = o1 thenCmp o1 _ = o1
class ConstVal a where data ConstVal where
randomValue :: a -> RVar a ConstVal :: (Typeable a, Ord a, Hashable a, Show a) => Ref.TypeRep a -> RVar a -> ConstVal
data ExpressionWeights = ExpressionWeights
{ application :: Int,
abstraction :: Int,
variableReference :: Int,
constant :: Int,
-- chance in percent an Application will (try to) work towards something from the boundVars becoming usable. I recommend values over 90.
functionBias :: Int
}
data LambdaEnviroment a = LambdaEnviroment
{ functions :: [BoundSymbol],
constants :: [ConstVal],
maxDepth :: Int,
weights :: ExpressionWeights,
-- likelyhood of an sub-expression to be mutated
mutationStrength :: Float,
-- likelyhood of an crossover attempt at a sub-expression
crossoverStrength :: Float
}
data FittnesRes = FittnesRes
{ total :: R,
fitnessTotal :: R,
fitnessGeoMean :: R,
fitnessMean :: R,
accuracy :: R,
biasSize :: R,
totalSize :: N
}
deriving (Show)
instance Fitness FittnesRes where
getR = total
data Dataset t where
Input :: (Typeable a, Typeable b) => [a] -> Dataset b -> Dataset (a -> b)
Result :: (Typeable a, Eq a, Enum a, Bounded a) => [a] -> Dataset a
data ExecutionEnviroment e = ExecutionEnviroment {
fun :: [BoundSymbol],
training :: Bool,
trainingData :: Dataset e,
testData :: Dataset e
}
data ResultList where
Res :: (Typeable a, Eq a, Enum a, Bounded a) => [(a,a)] -> ResultList
instance Typeable a => Evaluator (SimplyTypedLambdaExpression a) (ExecutionEnviroment a) FittnesRes where
fitness' ee@(ExecutionEnviroment {fun}) e = evalResult ee e (eval fun e)
evalResult :: ExecutionEnviroment a -> SimplyTypedLambdaExpression a -> a -> FittnesRes
evalResult (ExecutionEnviroment {training, trainingData, testData}) tr result = FittnesRes
{ total = (\(Res r) -> meanOfDistributionAccuracy r) res,
fitnessTotal = fitness',
fitnessMean = (\(Res r) -> meanOfAccuricyPerClass r) res ,
fitnessGeoMean = (\(Res r) -> meanOfDistributionAccuracy r) res,
accuracy = acc,
biasSize = biasSmall,
totalSize = expSize tr
}
where
dataS = (if training then trainingData else testData)
res = apply result dataS
acc = (\(Res r) -> (foldr (\(ts) s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 r) / fromIntegral (length r)) res
biasSmall = exp ((-(fromIntegral (expSize tr))) / 1000) -- 0 (schlecht) bis 1 (gut)
fitness' = (\(Res r) -> meanOfAccuricyPerClass r) res
score = fitness' + (biasSmall - 1)
apply :: a -> Dataset a -> ResultList
apply fun (Input b c) = applyL (map fun b) c
apply val (Result b) = Res (zip b (repeat val))
applyL :: [a] -> Dataset a -> ResultList
applyL fun (Input b c) = applyL (zipWith (\a b -> a b) fun b) c
applyL val (Result b) = Res (zip b val)
hasSymbolOfType :: forall (a :: Type). [BoundSymbol] -> Ref.TypeRep a -> Bool
hasSymbolOfType bound tr = length ((getSymbolsOfType bound tr) :: [a]) /= 0
getSymbolsOfType :: forall a. [BoundSymbol] -> Ref.TypeRep a -> [a]
getSymbolsOfType bound tr = mapMaybe (getIfType tr) bound
getBoundSymbolsOfType :: forall a. [BoundSymbol] -> Ref.TypeRep a -> [BoundSymbol]
getBoundSymbolsOfType bound tr = mapMaybe (getSymbolIfType tr) bound
getSymbolIfType :: forall a. Ref.TypeRep a -> BoundSymbol -> Maybe BoundSymbol
getSymbolIfType rep b@(BoundSymbol t _ _)
| Just Ref.HRefl <- t `Ref.eqTypeRep` rep = Just b
| otherwise = Nothing
getIfType :: forall a. Ref.TypeRep a -> BoundSymbol -> Maybe a
getIfType rep (BoundSymbol t val _)
| Just Ref.HRefl <- t `Ref.eqTypeRep` rep = Just val
| otherwise = Nothing
startingBindings :: [BoundSymbol] -> Bindings
startingBindings functions = (foldr (\(BoundSymbol tr _ _) map -> Map.insertWith (+) (Ref.SomeTypeRep tr) 1 map) Map.empty functions)
showSanifid :: (Show a) => a -> Text
showSanifid var = T.replace " -> " "To" (show var)
toDotE :: LambdaEnviroment a -> Text
toDotE (LambdaEnviroment {functions}) = foldr (<>) "" (map (\(BoundSymbol tr _ t, inx) -> "\"" <> (showSanifid tr) <> show inx <> "\" [style = invis label = " <> fromJust t <>"\"]\n") (concatMap (\(Ref.SomeTypeRep k,v) -> zip (getBoundSymbolsOfType functions k)[0 .. (v-1)]) (Map.toList (startingBindings functions))))
toDotI :: SimplyTypedLambdaExpression e -> Int -> Text
toDotI (Application e1 e2) inx = "\"app" <> show inx <> "\" -- " <> toDotI e1 (inx + 1) <> "\n" <> "\"app" <> show inx <> "\" -- " <> toDotI e2 (inx + 1 + expSize e1)
toDotI (Abstraction _ e) inx = "\"abs" <> show inx <> "\" -- " <> toDotI e (inx + 1)
toDotI (VariableReference tr i) _ = "\"" <> (showSanifid tr) <> show i <> "\""
toDotI (Constant c) _ = "\"" <> show c <> "\""
instance Eq SomeSimplyTypedLambdaExpression where
e1 == e2 = compare e1 e2 == EQ
instance Ord SomeSimplyTypedLambdaExpression where
compare (SomeSimplyTypedLambdaExpression (e1 :: SimplyTypedLambdaExpression a)) (SomeSimplyTypedLambdaExpression (e2 :: SimplyTypedLambdaExpression b))
| Just Refl <- eqT @a @b = compare e1 e2
| otherwise = compare (Ref.SomeTypeRep (Ref.TypeRep @a)) (Ref.SomeTypeRep (Ref.TypeRep @b))
instance Typeable a => Individual (SimplyTypedLambdaExpression a)
instance Typeable a => Environment (SimplyTypedLambdaExpression a) (LambdaEnviroment a) where
output env i = toDotE env <> toDotI i 0
nX _ = 3
new env = DB.trace "new !" ((generateFromEnv env) :: RVar (SimplyTypedLambdaExpression a))
mutate env le = (mutateUnwrapped env le)
crossover1 env le le2 = crossoverUnwrapper env le le2
crossoverUnwrapper :: (Typeable a) => LambdaEnviroment a -> SimplyTypedLambdaExpression a -> SimplyTypedLambdaExpression a -> RVar (Maybe (SimplyTypedLambdaExpression a, SimplyTypedLambdaExpression a))
crossoverUnwrapper env@(LambdaEnviroment {maxDepth, functions}) le1 le2 =
( do
(tree1, tree2) <- crossedover le1 le2 env maxDepth (startingBindings functions)
return $ if (tree2 == le2) then Nothing else Just (tree1, tree2)
)
crossedover :: forall a e. (Typeable a,Typeable e) => SimplyTypedLambdaExpression a -> SimplyTypedLambdaExpression e -> LambdaEnviroment e -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression a, SimplyTypedLambdaExpression e)
crossedover le1 le2 env@(LambdaEnviroment {crossoverStrength, maxDepth, functions}) sizeLeft bound = do
roll <- uniform 0 1
let crossoverChild =
( case le1 of
(Application e1 e2) ->
( do
(elm1, partner1) <- crossedover e1 le2 env ((sizeLeft - 1) - expSize e2) bound
(elm2, partner2) <- crossedover e2 le2 env ((sizeLeft - 1) - expSize e1) bound
leftMutated <- uniform False True
let mutateLeft = if partner1 == le2 then False else (if partner2 == le2 then False else leftMutated)
return $ if mutateLeft then (Application elm1 e2, partner1) else (Application e1 elm2, partner2)
)
(Abstraction tr e) ->
( do
(elm2, partner2) <- crossedover e le2 env (sizeLeft - 1) (Map.insertWith (+) (Ref.SomeTypeRep tr) 1 bound)
return $ (Abstraction tr elm2, partner2)
)
_ -> return (le1, le2)
)
if (roll < crossoverStrength)
then
( do
maybeSwapped <- trySwapSubtree le1 sizeLeft bound le2 maxDepth (startingBindings functions)
case maybeSwapped of
Just (ler1, ler2) -> return (ler1, ler2)
_ -> crossoverChild
)
else crossoverChild
trySwapSubtree :: forall a e.(Typeable a,Typeable e) => SimplyTypedLambdaExpression a -> Int -> Bindings -> SimplyTypedLambdaExpression e -> Int -> Bindings -> RVar (Maybe (SimplyTypedLambdaExpression a, SimplyTypedLambdaExpression e))
trySwapSubtree le1 sizeLeft bound le2 sizeLeft2 bound2 = do
let possible = possibleSwapSubtrees le1 sizeLeft bound le2 sizeLeft2 bound2
case possible of
[] -> return Nothing
ne -> Just <$> randomElement ne
possibleSwapSubtrees :: forall a e.(Typeable a,Typeable e) => SimplyTypedLambdaExpression a -> Int -> Bindings -> SimplyTypedLambdaExpression e -> Int -> Bindings -> [(SimplyTypedLambdaExpression a, SimplyTypedLambdaExpression e)]
possibleSwapSubtrees le1 sizeLeft bound le2 sizeLeft2 bound2
| Just Refl <- eqT @a @e = if compatibleSubtree sizeLeft2 bound2 le1 && compatibleSubtree sizeLeft bound le2 then (adaptSubtree bound2 le1, adaptSubtree bound le2) : continue else continue
| otherwise = continue
where
continue = (case le2 of
Application e1 e2 -> (map (\(li1,li2) -> (li1, (Application e1 li2))) (possibleSwapSubtrees le1 sizeLeft bound e2 (sizeLeft2 - 1 - expSize e1) bound2) ) ++ (map (\(li1,li2) -> (li1, (Application li2 e2))) (possibleSwapSubtrees le1 sizeLeft bound e1 (sizeLeft2 - 1 - expSize e2) bound2) )
Abstraction t e -> (map (\(li1,li2) -> (li1, (Abstraction t li2))) (possibleSwapSubtrees le1 sizeLeft bound e (sizeLeft2 - 1) (addToBindings t bound2)))
_ -> [])
addToBindings ::Ref.TypeRep a -> Bindings -> Bindings
addToBindings t bound = (Map.insertWith (+) (Ref.SomeTypeRep t) 1 bound)
adaptSubtree :: Bindings -> SimplyTypedLambdaExpression e -> SimplyTypedLambdaExpression e
adaptSubtree bound (Application e1 e2) = (Application (adaptSubtree bound e1) (adaptSubtree bound e2))
adaptSubtree bound (Abstraction t e) = (Abstraction t (adaptSubtree (addToBindings t bound) e))
adaptSubtree bound (VariableReference tr idx) = (VariableReference tr (mod idx ( bound Map.! (Ref.SomeTypeRep tr))))
adaptSubtree _ e = e
compatibleSubtree :: Int -> Bindings -> SimplyTypedLambdaExpression e -> Bool
compatibleSubtree sizeLeft bound subtree = bound `bindingContains` (bindingReq subtree) && sizeLeft > (expSize subtree)
expSize :: SimplyTypedLambdaExpression e -> Int
expSize (Application e1 e2) = expSize e1 + expSize e2 + 1
expSize (Abstraction _ e) = expSize e + 1
expSize _ = 1
bindingReq :: SimplyTypedLambdaExpression e -> Bindings
bindingReq (Application e1 e2) = Map.unionWith (max) (bindingReq e1) (bindingReq e2)
bindingReq (Abstraction tr e) = rmFromBindings tr (bindingReq e)
bindingReq (VariableReference tr idx) = Map.singleton (Ref.SomeTypeRep tr) 1
bindingReq (Constant _) = Map.empty
rmFromBindings ::Ref.TypeRep a -> Bindings -> Bindings
rmFromBindings t bound = (Map.insertWith (\i1 i2 -> max 0 (i1 + i2)) (Ref.SomeTypeRep t) (- 1) bound)
bindingContains :: Bindings -> Bindings -> Bool
bindingContains superset subset = all (\(key,val) -> (fromMaybe 0 (Map.lookup key superset)) >= val ) (Map.toList subset)
mutateUnwrapped :: (Typeable r) => LambdaEnviroment r -> SimplyTypedLambdaExpression r -> RVar (SimplyTypedLambdaExpression r)
mutateUnwrapped env@(LambdaEnviroment {maxDepth, functions}) stle = mutated stle env maxDepth (startingBindings functions)
mutated :: forall r a. (Typeable r) => SimplyTypedLambdaExpression r -> LambdaEnviroment a -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
mutated (Application e1 e2) env@(LambdaEnviroment {constants, mutationStrength}) sizeLeft bound = do
roll <- uniform 0 1
if (roll < mutationStrength)
then generate env (Ref.TypeRep @r) constants sizeLeft bound
else do
sizeDistribution <- uniform 0 (sizeLeft - 1)
elm1 <- mutated e1 env sizeDistribution bound
elm2 <- mutated e2 env ((sizeLeft - 1) - sizeDistribution) bound
return $ Application elm1 elm2
mutated (Abstraction tr e) env@(LambdaEnviroment {constants, mutationStrength}) sizeLeft bound = do
roll <- uniform 0 1
if (roll < mutationStrength)
then generate env (Ref.TypeRep @r) constants sizeLeft bound
else do
elm2 <- mutated e env (sizeLeft - 1) (Map.insertWith (+) (Ref.SomeTypeRep tr) 1 bound)
return $ Abstraction tr elm2
mutated stle env@(LambdaEnviroment {constants, mutationStrength}) sizeLeft bound = do
roll <- uniform 0 1
if (roll < mutationStrength) then generate env (Ref.TypeRep @r) constants sizeLeft bound else return stle
test :: SimplyTypedLambdaExpression (Bool -> Int -> Int -> Int) test :: SimplyTypedLambdaExpression (Bool -> Int -> Int -> Int)
test = Abstraction (Ref.typeRep @(Bool)) (Abstraction (Ref.typeRep @(Int)) (Abstraction (Ref.typeRep @(Int)) (Constant 5))) test = Abstraction (Ref.typeRep @(Bool)) (Abstraction (Ref.typeRep @(Int)) (Abstraction (Ref.typeRep @(Int)) (Constant 5)))
generate :: ConstVal c => Ref.TypeRep r -> [c] -> Int -> BoundVars -> RVar (SimplyTypedLambdaExpression r) generateFromEnv :: forall r. (Typeable r) => LambdaEnviroment r -> RVar (SimplyTypedLambdaExpression r)
generate targetType constantTypes sizeLeft bound = undefined generateFromEnv env@(LambdaEnviroment {functions, constants, maxDepth}) = generate env (Ref.TypeRep @r) constants maxDepth (foldr (\(BoundSymbol tr _ _) map -> Map.insertWith (+) (Ref.SomeTypeRep tr) 1 map) Map.empty functions)
eval :: BoundVars -> SimplyTypedLambdaExpression ex -> ex generate :: LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
generate env tr@(Ref.Fun (Ref.TypeRep @a) (Ref.TypeRep @b)) constantTypes sizeLeft bound
| (sizeLeft > 0) && (Map.member (Ref.SomeTypeRep tr) bound) = do
let weight = weights env
let options = [(application weight, genApplication env tr constantTypes sizeLeft bound), (abstraction weight, genAbstraction env tr constantTypes sizeLeft bound), (variableReference weight, genVariableReference env tr constantTypes sizeLeft bound)]
expres <- selectWeighted options
res <- expres
return res
| (sizeLeft > 0) = do
let weight = weights env
let options = [(application weight + round (1000 * closestFractionMatch tr bndK), genApplication env tr constantTypes sizeLeft bound), (abstraction weight, genAbstraction env tr constantTypes sizeLeft bound)]
expres <- selectWeighted options
res <- expres
return res
-- Application can crate a fitting type in a smaller expression. e.g. if':: Bool -> (Int-> Int -> Bool) -> (Int-> Int -> Bool) -> (Int-> Int -> Bool) and target type (Int-> Int -> Bool) -> (Int-> Int -> Bool) -> (Int-> Int -> Bool) can be finished in one Application (if' True::(Int-> Int -> Bool) -> (Int-> Int -> Bool) -> (Int-> Int -> Bool)) and one Var or constant, but resoving it purely with Abstractions would require 5 abstractions and one constant or var
-- | (any (< typeDepth tr) (mapMaybe (sizeMising tr) bndK)) = do
-- let weight = weights env
-- let options = [(application weight + (typeDepth tr - (minimum (mapMaybe (sizeMising tr) bndK))), genApplication env tr constantTypes sizeLeft bound), (abstraction weight, genAbstraction env tr constantTypes sizeLeft bound)]
-- expres <- selectWeighted options
-- res <- expres
-- return res
| (Map.member (Ref.SomeTypeRep tr) bound) = do
let weight = weights env
let options = [(abstraction weight, genAbstraction env tr constantTypes sizeLeft bound), (variableReference weight, genVariableReference env tr constantTypes sizeLeft bound)]
expres <- selectWeighted options
res <- expres
return res
| otherwise = do
res <- genAbstraction env tr constantTypes sizeLeft bound
return res
where
bndK = Map.keys bound
generate env tr constantTypes sizeLeft bound
| (sizeLeft > 0) && (Map.member (Ref.SomeTypeRep tr) bound) = do
let weight = weights env
let options = [(application weight, genApplication env tr constantTypes sizeLeft bound), (constant weight, genConstant tr constantTypes sizeLeft bound), (variableReference weight, genVariableReference env tr constantTypes sizeLeft bound)]
expres <- selectWeighted options
res <- expres
return res
| (sizeLeft > 0) = do
let weight = weights env
let options = [(application weight + round (1000 * closestFractionMatch tr bndK), genApplication env tr constantTypes sizeLeft bound), (constant weight, genConstant tr constantTypes sizeLeft bound)]
expres <- selectWeighted options
res <- expres
return res
| (Map.member (Ref.SomeTypeRep tr) bound) = do
let weight = weights env
let options = [(constant weight, genConstant tr constantTypes sizeLeft bound), (variableReference weight, genVariableReference env tr constantTypes sizeLeft bound)]
expres <- selectWeighted options
res <- expres
return res
| otherwise = do
res <- genConstant tr constantTypes sizeLeft bound
return res
where
bndK = Map.keys bound
genVariableReference :: LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
genVariableReference _ tr@(Ref.TypeRep) _ _ bound = do
typeIndex <- uniform 0 (((Map.!) bound (Ref.SomeTypeRep tr)) - 1)
return $ (VariableReference tr typeIndex)
genConstant :: Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
genConstant (Ref.TypeRep @a) constantTypes _ _ = do
val <- (constantGen constantTypes) :: RVar (SimplyTypedLambdaExpression a)
return $ val
constantGen :: forall a. (Typeable a) => [ConstVal] -> RVar (SimplyTypedLambdaExpression a)
constantGen ((ConstVal tr rVal) : rest)
| Just Ref.HRefl <- Ref.typeRep @a `Ref.eqTypeRep` tr = Constant <$> rVal
| otherwise = constantGen rest
constantGen [] = error $ "unknown constant " <> show (Ref.typeRep @a)
genAbstraction :: forall r a. LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
genAbstraction env tr@(Ref.Fun trA@(Ref.TypeRep) trB@(Ref.TypeRep)) constantTypes sizeLeft bound
| Just Ref.HRefl <- Ref.typeRep @Type `Ref.eqTypeRep` Ref.typeRepKind trA,
Just Ref.HRefl <- Ref.typeRep @Type `Ref.eqTypeRep` Ref.typeRepKind trB = do
child <- generate env trB constantTypes (sizeLeft - 1) (Map.insertWith (+) (Ref.SomeTypeRep trA) 1 bound)
return $ Abstraction trA child
genAbstraction _ tr _ _ _ = error $ "cannot generate Abstraction for " <> show tr
-- generate: e:a = e1:b->a e2:b
-- the by far most complex functions in this module! why?
-- 1. we need to sensibly limit how insane we make b, favorably without excluding anything completely!
-- 2. we need this function to heavily lean towards generating an b->a available in Bindings, so we are likely to use any predefined functions... at all
genApplication :: forall r c a. LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
genApplication env@(LambdaEnviroment {weights}) tr constantTypes sizeLeft bound
| (sizeLeft <= 0) = genApplicationClosestToCompletion env tr constantTypes bound
| otherwise = do
i <- uniform 0 100
( if i < (functionBias weights) && any (1 >) (mapMaybe (matchedFractionS tr) (Map.keys bound))
then (genApplicationTowardsBound (maximum (filter (1 >) (mapMaybe (matchedFractionS tr) (Map.keys bound)))) env tr constantTypes sizeLeft bound)
else (genRandomApplication env tr constantTypes sizeLeft bound)
)
closestFractionMatch :: Ref.TypeRep r -> [Ref.SomeTypeRep] -> Float
closestFractionMatch tr trs | any (1 >) (mapMaybe (matchedFractionS tr) (trs)) = (maximum (filter (1 >) (mapMaybe (matchedFractionS tr) (trs))))
| otherwise = 0
genRandomApplication :: forall a r c. LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
genRandomApplication env tr constantTypes sizeLeft bound = do
t1 <- randomType constantTypes
genApplicationWithTypeOfS t1 env tr constantTypes sizeLeft bound
randomType :: [ConstVal] -> RVar Ref.SomeTypeRep
randomType constantTypes = do
functon :: Int <- (uniform 0 100)
ret <-
if functon < 25
then
( do
tr1 <- randomType constantTypes
tr2 <- randomType constantTypes
return (mkFunTy tr1 tr2)
)
else
( do
(ConstVal _ (_ :: RVar t1)) <- randomElement constantTypes
return $ Ref.SomeTypeRep (Ref.TypeRep @t1)
)
return ret
genApplicationClosestToCompletion :: forall r a. LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Bindings -> RVar (SimplyTypedLambdaExpression r)
genApplicationClosestToCompletion env tr constantTypes bound = do
(ref) <- nextTypeFromClosestBound tr bound
genApplicationWithTypeOfS ref env tr constantTypes 0 bound
nextTypeFromClosestBound :: Ref.TypeRep r -> Bindings -> RVar Ref.SomeTypeRep
nextTypeFromClosestBound trB bound = randomElement ((getMinimasByMaybe (sizeMising trB) (filter (matchingTypesS trB) (Map.keys bound))))
genApplicationTowardsBound :: forall r c a. Float -> LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
genApplicationTowardsBound matchedFrac env tr constantTypes sizeLeft bound
| nextMatchedFrac > 0 = do
(f :: Float) <- uniform 0 1
bs <- randomElement (filter (\bs -> Just matchedFrac == matchedFractionS tr bs) (Map.keys bound))
if (f < matchedFrac + 1) then (genApplicationWithTypeOfS ((nextTypeS tr bs)) env tr constantTypes sizeLeft bound) else (genApplicationTowardsBound nextMatchedFrac env tr constantTypes sizeLeft bound)
| otherwise = do
bs <- randomElement (filter (\bs -> Just matchedFrac == matchedFractionS tr bs) (Map.keys bound))
genApplicationWithTypeOfS ((nextTypeS tr bs)) env tr constantTypes sizeLeft bound
where
nextMatchedFrac = (if (any (matchedFrac >) (mapMaybe (matchedFractionS tr) (Map.keys bound))) then (maximum (filter (matchedFrac >) (mapMaybe (matchedFractionS tr) (Map.keys bound)))) else 0) --todo nicer!
-- how many Base types will need to be generated for bound to fit onto tr. This equals the size of the subtree that needs to be generated.
sizeMising :: Ref.TypeRep r -> Ref.SomeTypeRep -> Maybe Int
sizeMising tr (Ref.SomeTypeRep trbs)
| matchingTypes tr trbs = Just $ (typeDepth tr) - (typeDepth trbs)
| otherwise = Nothing
matchedFractionS :: Ref.TypeRep r -> Ref.SomeTypeRep -> Maybe Float
matchedFractionS tr (Ref.SomeTypeRep trbs) = matchedFraction tr trbs
matchedFraction :: Ref.TypeRep r -> Ref.TypeRep a -> Maybe Float
matchedFraction tr trbs
| matchingTypes tr trbs = Just $ fromIntegral (typeDepth trbs) / fromIntegral (typeDepth tr)
| otherwise = Nothing
nextTypeS :: Ref.TypeRep r -> Ref.SomeTypeRep -> Ref.SomeTypeRep
nextTypeS tr (Ref.SomeTypeRep trbs) = nextType tr trbs
nextType :: Ref.TypeRep r -> Ref.TypeRep a -> Ref.SomeTypeRep
nextType trR@(Ref.Fun (from) (to)) avail
| Just Ref.HRefl <- (to `Ref.eqTypeRep` avail),
Just Ref.HRefl <- Ref.typeRep @Type `Ref.eqTypeRep` Ref.typeRepKind from =
Ref.SomeTypeRep from
| otherwise = nextType to avail
nextType tra trbs = error ("can't extract nextType from " <> show tra <> " and " <> show trbs)
matchingTypesS :: Ref.TypeRep r -> Ref.SomeTypeRep -> Bool
matchingTypesS tr (Ref.SomeTypeRep trbs) = matchingTypes tr trbs
matchingTypes :: Ref.TypeRep a -> Ref.TypeRep b -> Bool
matchingTypes tra trb | Ref.SomeTypeRep tra == Ref.SomeTypeRep trb = True
matchingTypes (Ref.Fun _ (traRes :: Ref.TypeRep aRes)) trb = matchingTypes (traRes :: Ref.TypeRep aRes) trb
matchingTypes _ _ = False
typeSize :: Ref.TypeRep r -> Int
typeSize (Ref.Fun _ trb) = 1 + (typeSize trb)
typeSize _ = 1
typeDepth :: Ref.TypeRep r -> Int
typeDepth (Ref.Fun _ (trb :: Ref.TypeRep b)) = 1 + (typeDepth (trb :: Ref.TypeRep b))
typeDepth _ = 1
genApplicationWithTypeOfS :: forall r a. Ref.SomeTypeRep -> LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
genApplicationWithTypeOfS (Ref.SomeTypeRep btr@(Ref.TypeRep))
| Just Ref.HRefl <- Ref.typeRep @Type `Ref.eqTypeRep` Ref.typeRepKind btr = genApplicationWithTypeOfB btr
genApplicationWithTypeOfS (Ref.SomeTypeRep btr) = error $ "typeRepKind not Type: " <> show (Ref.typeRepKind btr)
genApplicationWithTypeOfB :: forall r a (b :: Type). Ref.TypeRep b -> LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
genApplicationWithTypeOfB trB@(Ref.TypeRep) env trR@(Ref.TypeRep) constantTypes sizeLeft bound = do
sizeDistribution <- uniform 0 (sizeLeft - 1)
right <- generate env trB constantTypes sizeDistribution bound
left <- generate env (Ref.Fun (Ref.TypeRep @b) trR) constantTypes ((sizeLeft - 1) - sizeDistribution) bound
return $ Application left right
selectWeighted :: [(Int, a)] -> RVar a
selectWeighted x = do
let total = Protolude.sum (map fst x)
selection <- uniform 1 total
return $ selectAtWeight selection (NE.fromList x)
selectAtWeight :: Int -> NonEmpty (Int, a) -> a
selectAtWeight _ (x :| []) = snd x
selectAtWeight w (x :| xs)
| fst x >= w = snd x
| otherwise = selectAtWeight (w - fst x) (NE.fromList xs)
eval :: [BoundSymbol] -> SimplyTypedLambdaExpression ex -> ex
eval bound (Abstraction rep stle) = lam bound rep stle eval bound (Abstraction rep stle) = lam bound rep stle
eval bound (Application stleAtoB stleA) = (eval bound stleAtoB) (eval bound stleA) eval bound (Application stleAtoB stleA) = (eval bound stleAtoB) (eval bound stleA)
eval bound (VariableReference rep inx) = fromDyn ( (bound Map.! (Ref.SomeTypeRep rep)) !! inx) (error ("we couldn't find " <> (show rep) <> " in our boundVars: " <> (show bound))) eval bound (VariableReference rep inx) = (getSymbolsOfType bound rep) !! inx
eval _ (Constant res) = res eval _ (Constant res) = res
lam :: [BoundSymbol] -> Ref.TypeRep a -> SimplyTypedLambdaExpression (b) -> (a -> b)
lam :: BoundVars -> Ref.TypeRep a -> SimplyTypedLambdaExpression (b) -> (a -> b)
lam bound Ref.TypeRep stle = \(aVal :: a) -> eval (appendToBoundVar bound aVal) stle lam bound Ref.TypeRep stle = \(aVal :: a) -> eval (appendToBoundVar bound aVal) stle
appendToBoundVar :: (Typeable a) => BoundVars -> a -> BoundVars appendToBoundVar :: (Typeable a) => [BoundSymbol] -> a -> [BoundSymbol]
appendToBoundVar bv val = Map.alter (listAppend val) (Ref.SomeTypeRep (Ref.typeOf val)) bv appendToBoundVar bv val = bv ++ [BoundSymbol (Ref.typeOf val) val Nothing]
listAppend :: (Typeable a) => a -> Maybe [Dynamic] -> Maybe [Dynamic]
listAppend::(Typeable a) => a -> Maybe [Dynamic] -> Maybe [Dynamic]
listAppend val (Just dyns) = Just (dyns ++ [toDyn val]) listAppend val (Just dyns) = Just (dyns ++ [toDyn val])
listAppend val (Nothing) = Just [toDyn val] listAppend val (Nothing) = Just [toDyn val]
getMinimasBy :: (Ord b) => (a -> b) -> [a] -> [a]
getMinimasBy fun as = filter (\a -> fun a == minOverAs) as
where
minOverAs = minimum (map fun as)
getMinimasByMaybe :: (Ord b) => (a -> Maybe b) -> [a] -> [a]
getMinimasByMaybe fun as = filter (\a -> fun a == Just minOverAs) as
where
minOverAs = minimum (mapMaybe fun as)
getMaximasBy :: (Ord b) => (a -> b) -> [a] -> [a]
getMaximasBy fun as = filter (\a -> fun a == maxOverAs) as
where
maxOverAs = maximum (map fun as)
getMaximasByMaybe :: (Ord b) => (a -> Maybe b) -> [a] -> [a]
getMaximasByMaybe fun as = filter (\a -> fun a == Just maxOverAs) as
where
maxOverAs = maximum (mapMaybe fun as)

3
lib/Utils.hs
View File

@ -20,6 +20,9 @@ geomeanOfAccuricyPerClass results = geomean $ map (accuracyInClass results) [min
geomeanOfDistributionAccuracy :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R geomeanOfDistributionAccuracy :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
geomeanOfDistributionAccuracy results = geomean $ map (distributionAccuracyForClass results) [minBound .. maxBound] geomeanOfDistributionAccuracy results = geomean $ map (distributionAccuracyForClass results) [minBound .. maxBound]
meanOfDistributionAccuracy :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
meanOfDistributionAccuracy results = mean $ map (distributionAccuracyForClass results) [minBound .. maxBound]
distributionAccuracyForClass :: (Eq r) => [(r, r)] -> r -> R 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 distributionAccuracyForClass results clas = (1 - (min 1 (fromIntegral (abs ((length (inResClass results clas)) - (length (inClass results clas)))) / fromIntegral (length (inClass results clas))))) * 100

3
src-students/Main.hs
View File

@ -4,7 +4,6 @@
import Options.Applicative import Options.Applicative
import Pipes import Pipes
import Pretty
import Protolude hiding (for) import Protolude hiding (for)
import System.IO import System.IO
import Seminar import Seminar
@ -65,6 +64,6 @@ main =
where where
format seminarL s = do format seminarL s = do
let f = fitness' seminarL s let f = fitness' seminarL s
putErrText $ show f <> "\n" <> pretty s putErrText $ show f <> "\n" <> output (AssignmentEnviroment (students prios, topics prios)) s
logCsv = putText . csv logCsv = putText . csv
csv (t, f) = show t <> " " <> show f csv (t, f) = show t <> " " <> show f

16
src-students/Seminar.hs
View File

@ -107,6 +107,14 @@ instance Pretty AssignmentEnviroment where
pretty (AssignmentEnviroment (persons,assignables)) = "Persons: " <> show persons <> " Assignables: " <> show assignables pretty (AssignmentEnviroment (persons,assignables)) = "Persons: " <> show persons <> " Assignables: " <> show assignables
instance Environment Assignment AssignmentEnviroment where instance Environment Assignment AssignmentEnviroment where
output _ a =
T.unlines (gene <$> a)
where
gene :: (Maybe Student, Maybe Topic) -> Text
gene (s, t) =
pretty s <> ": " <> pretty t
new (AssignmentEnviroment (persons,assignables)) = do new (AssignmentEnviroment (persons,assignables)) = do
let aPadding = replicate (length persons - length assignables) Nothing let aPadding = replicate (length persons - length assignables) Nothing
let paddedAssignables = (Just <$> assignables) ++ aPadding let paddedAssignables = (Just <$> assignables) ++ aPadding
@ -139,14 +147,6 @@ instance Environment Assignment AssignmentEnviroment where
f x v1 v2 i = if i <= x then v1 else v2 f x v1 v2 i = if i <= x then v1 else v2
instance Pretty Assignment where
pretty (a) =
T.unlines (gene <$> a)
where
gene :: (Maybe Student, Maybe Topic) -> Text
gene (s, t) =
pretty s <> ": " <> pretty t
-- | -- |
-- The priority value given by a student to a topic including the case of her not -- The priority value given by a student to a topic including the case of her not
-- receiving a topic. -- receiving a topic.