Compare commits

..

1 Commits

Author SHA1 Message Date
Johannes Merl
c261fcdfbb split of dataset 2024-03-11 10:59:18 +01:00
28 changed files with 335 additions and 15280 deletions

View File

@@ -1,9 +0,0 @@
#!/usr/bin/env bash
#SBATCH --time=00:10:00
#SBATCH --partition=cpu
#SBATCH --output=./output/output_build.txt
#SBATCH --error=./output/error_build.txt
#SBATCH --nodelist=oc-compute02
#SBATCH --mem=4G
#SBATCH -c16
srun nix develop --command stack --no-nix --system-ghc --no-install-ghc build

8
flake.lock generated
View File

@@ -2,17 +2,17 @@
"nodes": {
"nixpkgs": {
"locked": {
"lastModified": 1713145326,
"narHash": "sha256-m7+IWM6mkWOg22EC5kRUFCycXsXLSU7hWmHdmBfmC3s=",
"lastModified": 1655624069,
"narHash": "sha256-7g1zwTdp35GMTERnSzZMWJ7PG3QdDE8VOX3WsnOkAtM=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "53a2c32bc66f5ae41a28d7a9a49d321172af621e",
"rev": "0d68d7c857fe301d49cdcd56130e0beea4ecd5aa",
"type": "github"
},
"original": {
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "53a2c32bc66f5ae41a28d7a9a49d321172af621e",
"rev": "0d68d7c857fe301d49cdcd56130e0beea4ecd5aa",
"type": "github"
}
},

View File

@@ -2,7 +2,8 @@
description = "Flake for haga";
inputs = {
nixpkgs.url =
"github:NixOS/nixpkgs/53a2c32bc66f5ae41a28d7a9a49d321172af621e";
# 2022-06-22
"github:NixOS/nixpkgs/0d68d7c857fe301d49cdcd56130e0beea4ecd5aa";
};
@@ -13,12 +14,10 @@
# defaultPackage.${system} = haskellPackages.callPackage ./default.nix { };
devShell.${system} = mkShell {
buildInputs = [
haskell.compiler.ghc981
git
gcc
gmp
feedgnuplot
stack
haskellPackages.cabal-install
haskellPackages.ormolu
haskell.compiler.ghc8107
];
};
};

View File

@@ -1,4 +1,4 @@
cabal-version: 3.4
cabal-version: 2.2
name: haga
version: 0.1.0.0
synopsis: Simplistic genetic algorithms library
@@ -30,7 +30,6 @@ library
, MonadRandom
, mwc-random
, optparse-applicative
, parallel
, path
, pipes
, primitive
@@ -43,30 +42,27 @@ library
, text
, wl-pprint-text
default-language: Haskell2010
ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -O2
hs-source-dirs: lib, lambda/lib
other-modules: CommonDefinition
ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
hs-source-dirs: src
exposed-modules: GA
, LambdaCalculus
, Seminar
, Pretty
, Utils
, LambdaDatasets.NurseryDefinition
, LambdaDatasets.GermanDefinition
, LambdaDatasets.IrisDefinition
, Szenario191
, LambdaCalculus
, IrisDataset
, IrisData
executable haga-lambda
executable haga
build-depends: base
, bytestring
, cassava
, containers
, extra
, hint
, haga
, monad-loops
, MonadRandom
, mwc-random
, optparse-applicative
, parallel
, path
, pipes
, primitive
@@ -80,32 +76,15 @@ executable haga-lambda
, wl-pprint-text
default-language: Haskell2010
ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
hs-source-dirs: lambda/src
hs-source-dirs: src
main-is: Main.hs
other-modules: LambdaDatasets.NurseryDataset
, LambdaDatasets.NurseryData
, LambdaDatasets.GermanDataset
, LambdaDatasets.GermanData
, LambdaDatasets.IrisDataset
, LambdaDatasets.IrisData
executable haga-students
build-depends: base
, extra
, haga
, optparse-applicative
, protolude
, pipes
, QuickCheck
, quickcheck-instances
, random-fu
, text
default-language: Haskell2010
ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
hs-source-dirs: src-students
main-is: Main.hs
other-modules: Seminar
other-modules: GA
, Seminar
, Pretty
, Szenario191
, LambdaCalculus
, IrisDataset
, IrisData
executable haga-test
build-depends: base
@@ -114,13 +93,11 @@ executable haga-test
, cassava
, containers
, extra
, haga
, hint
, monad-loops
, MonadRandom
, mwc-random
, optparse-applicative
, parallel
, path
, pipes
, primitive
@@ -134,5 +111,12 @@ executable haga-test
, wl-pprint-text
default-language: Haskell2010
ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
hs-source-dirs: lib
hs-source-dirs: src
main-is: Test.hs
other-modules: GA
, Seminar
, Pretty
, Szenario191
, LambdaCalculus
, IrisDataset
, IrisData

View File

@@ -1,17 +0,0 @@
# Why this split:
The Module(s) used when evaluating individuals has to be in an external library to make Hint work. so we split the lamda-calculus command program in a library we need to expose in the main library and the implementation.
Sadly, ghc / ghci / cabal can not properly make a public, internal library available to ghci (and, with that, Hint). Should this ever change:
```
library haga-lambda-lib
visibility: public
build-depends: base
, protolude
default-language: Haskell2010
ghc-options: -Wall -Wno-orphans -O2
hs-source-dirs: lambda/lib
other-modules: CommonDefinition
exposed-modules: LambdaDatasets.NurseryDefinition
```

View File

@@ -1,9 +0,0 @@
{-# LANGUAGE NoImplicitPrelude #-}
module CommonDefinition where
import Protolude
if' :: Bool -> a -> a -> a
if' True e _ = e
if' False _ e = e

View File

@@ -1,38 +0,0 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module LambdaDatasets.GermanDefinition
( module LambdaDatasets.GermanDefinition,
module CommonDefinition,
) where
import Protolude
import CommonDefinition
data GermanClass = Accept | Deny deriving (Eq, Generic, Show, Enum, Bounded)
data AccountStatus = AccountInDebt | NoAccount | LowAccountBalance | HighAccountBalanceOrRegular deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data CreditHistory = HistoryGood | HistoryGoodHere | HistoryGoodSoFar | DelaysInHistory | CreditsExist deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Purpose = OldCar | NewCar | FunitureOrEquipment | Tech | Appliances | Repairs | Education | Retraining | Business | Other deriving (Eq, Generic, Show, Enum, Bounded)
data Savings = UnknownOrNone | SmallSavings | NormalSavings | GoodSavings | GreatSavings deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data EmploymentStatus = NotEmployed | ShortTermEmployed | MediumTermEmployed | LongTermEmployed | VeteranEmployed deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data StatusAndSex = MaleAndSeperated | FemaleAndSeperatedOrMarried | MaleAndSingle | FemaleAndSingle | MaleAndWidowedOrMarried deriving (Eq, Generic, Show, Enum, Bounded)
data OtherDebtors = NoOtherDebtors | CoApplicant | Guarantor deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Property = UnknownOrNoProperty | RealEstate | Savings | CarOrOther deriving (Eq, Generic, Show, Enum, Bounded)
data OtherPlans = PlansAtBank | PlansAtStores | NoOtherPlans deriving (Eq, Generic, Show, Enum, Bounded)
data Housing = Renting | OwningRecidency | ResidingForFree deriving (Eq, Generic, Show, Enum, Bounded)
data Job = UnemployedOrUnskilledNonResident | UnskilledResident | Skilled | HighlySkilled deriving (Eq, Generic, Show, Enum, Bounded, Ord)

View File

@@ -1,16 +0,0 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module LambdaDatasets.IrisDefinition
( module LambdaDatasets.IrisDefinition,
module CommonDefinition,
) where
import Protolude
import CommonDefinition
data IrisClass = Setosa | Virginica | Versicolor deriving (Eq, Generic, Show, Enum, Bounded)

View File

@@ -1,32 +0,0 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module LambdaDatasets.NurseryDefinition
( module LambdaDatasets.NurseryDefinition,
module CommonDefinition,
) where
import Protolude
import CommonDefinition
data NurseryClass = NotRecommend | Recommend | VeryRecommend | Priority | SpecPriority deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Parents = Usual | Pretentious | GreatPret deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data HasNurs = ProperNurs | LessProperNurs | ImproperNurs | CriticalNurs | VeryCritNurs deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Form = CompleteFamilyForm | CompletedFamilyForm | IncompleteFamilyForm | FosterFamilyForm deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Children = OneChild | TwoChilds | ThreeChilds | MoreChilds deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Housing = ConvenientHousing | LessConvHousing | CriticalHousing deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Finance = ConvenientFinance | InconvFinance deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Social = NotProblematicSocial | SlightlyProblematicSocial | ProblematicSocial deriving (Eq, Generic, Show, Enum, Bounded, Ord)
data Health = NotRecommendHealth |RecommendedHealth | PriorityHealth deriving (Eq, Generic, Show, Enum, Bounded, Ord)

File diff suppressed because it is too large Load Diff

View File

@@ -1,208 +0,0 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module LambdaDatasets.GermanDataset
( module LambdaCalculus,
module LambdaDatasets.GermanDataset,
module LambdaDatasets.GermanData,
module GA,
)
where
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Random
import Data.Random.Distribution.Uniform
import qualified Data.Text as T
import Data.Tuple.Extra
import GA
import LambdaDatasets.GermanData
import LambdaCalculus
import qualified Language.Haskell.Interpreter as Hint
import qualified Language.Haskell.Interpreter.Unsafe as Hint
import Protolude
import Protolude.Error
import System.Random.MWC (createSystemRandom)
import qualified Type.Reflection as Ref
import Utils
lE :: LambdaEnviroment
lE =
LambdaEnviroment
{ functions =
Map.fromList
[ -- Math
((Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int))), ["(+)", "(-)", "(*)"]),
-- Logic
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
-- Ordered
((Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(AccountStatus -> AccountStatus -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(CreditHistory -> CreditHistory -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Savings -> Savings -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(EmploymentStatus -> EmploymentStatus -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(OtherDebtors -> OtherDebtors -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Job -> Job -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-- Eq
((Ref.SomeTypeRep (Ref.TypeRep @(GermanClass -> GermanClass -> Bool))), ["(==)", "(/=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Purpose -> Purpose -> Bool))), ["(==)", "(/=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(StatusAndSex -> StatusAndSex -> Bool))), ["(==)", "(/=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Property -> Property -> Bool))), ["(==)", "(/=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(OtherPlans -> OtherPlans -> Bool))), ["(==)", "(/=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Housing -> Housing -> Bool))), ["(==)", "(/=)"]),
-- Any Type
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Int -> Int -> Int))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> GermanClass -> GermanClass -> GermanClass))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> AccountStatus -> AccountStatus -> AccountStatus))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> CreditHistory -> CreditHistory -> CreditHistory))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Purpose -> Purpose -> Purpose))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Savings -> Savings -> Savings))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> EmploymentStatus -> EmploymentStatus -> EmploymentStatus))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> StatusAndSex -> StatusAndSex -> StatusAndSex))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> OtherDebtors -> OtherDebtors -> OtherDebtors))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Property -> Property -> Property))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> OtherPlans -> OtherPlans -> OtherPlans))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Housing -> Housing -> Housing))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Job -> Job -> Job))), ["if'"])
],
constants =
Map.fromList
[ ((Ref.SomeTypeRep (Ref.TypeRep @(Int))), [(fmap show (uniform 0 10 :: RVar Int))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool))), [(fmap show (uniform True False :: RVar Bool))]),
((Ref.SomeTypeRep (Ref.TypeRep @(GermanClass))), [(fmap show (enumUniform Accept Deny))]),
((Ref.SomeTypeRep (Ref.TypeRep @(AccountStatus))), [(fmap show (enumUniform AccountInDebt HighAccountBalanceOrRegular))]),
((Ref.SomeTypeRep (Ref.TypeRep @(CreditHistory))), [(fmap show (enumUniform HistoryGood CreditsExist ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Purpose))), [(fmap show (enumUniform OldCar Other ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Savings))), [(fmap show (enumUniform UnknownOrNone GreatSavings ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(EmploymentStatus))), [(fmap show (enumUniform NotEmployed VeteranEmployed ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(StatusAndSex))), [(fmap show (enumUniform MaleAndSeperated MaleAndWidowedOrMarried ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(OtherDebtors))), [(fmap show (enumUniform NoOtherDebtors Guarantor ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Property))), [(fmap show (enumUniform UnknownOrNoProperty CarOrOther ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(OtherPlans))), [(fmap show (enumUniform PlansAtBank NoOtherPlans ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Housing))), [(fmap show (enumUniform Renting ResidingForFree ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Job))), [(fmap show (enumUniform UnemployedOrUnskilledNonResident HighlySkilled ))])
],
targetType = (Ref.SomeTypeRep (Ref.TypeRep @(AccountStatus -> Int -> CreditHistory -> Purpose -> Int -> Savings -> EmploymentStatus -> Int -> StatusAndSex -> OtherDebtors -> Int -> Property -> Int -> OtherPlans -> Housing -> Int -> Job -> Int -> Bool -> Bool -> GermanClass))),
maxDepth = 5,
weights =
ExpressionWeights
{ lambdaSpucker = 10,
lambdaSchlucker = 1,
symbol = 20,
variable = 100,
constant = 5
}
}
lEE :: LamdaExecutionEnv
lEE =
LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports = ["LambdaDatasets.GermanDefinition"],
training = True,
trainingData =
( map fst (takeFraktion 0.8 germanTrainingData),
map snd (takeFraktion 0.8 germanTrainingData)
),
testData =
( map fst (dropFraktion 0.8 germanTrainingData),
map snd (dropFraktion 0.8 germanTrainingData)
),
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(AccountStatus -> Int -> CreditHistory -> Purpose -> Int -> Savings -> EmploymentStatus -> Int -> StatusAndSex -> OtherDebtors -> Int -> Property -> Int -> OtherPlans -> Housing -> Int -> Job -> Int -> Bool -> Bool -> GermanClass))),
results = Map.empty
}
shuffledLEE :: IO LamdaExecutionEnv
shuffledLEE = do
mwc <- liftIO createSystemRandom
let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
itD <- smpl $ shuffle germanTrainingData
return
LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports = ["LambdaDatasets.GermanDefinition"],
training = True,
trainingData =
( map fst (takeFraktion 0.8 itD),
map snd (takeFraktion 0.8 itD)
),
testData =
( map fst (dropFraktion 0.8 itD),
map snd (dropFraktion 0.8 itD)
),
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(AccountStatus -> Int -> CreditHistory -> Purpose -> Int -> Savings -> EmploymentStatus -> Int -> StatusAndSex -> OtherDebtors -> Int -> Property -> Int -> OtherPlans -> Housing -> Int -> Job -> Int -> Bool -> Bool -> GermanClass))),
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 :: ([(AccountStatus, Int, CreditHistory, Purpose, Int, Savings, EmploymentStatus, Int, StatusAndSex, OtherDebtors, Int, Property, Int, OtherPlans, Housing, Int, Job, Int, Bool, Bool)], [GermanClass]),
testData :: ([(AccountStatus, Int, CreditHistory, Purpose, Int, Savings, EmploymentStatus, Int, StatusAndSex, OtherDebtors, Int, Property, Int, OtherPlans, Housing, Int, Job, Int, Bool, Bool)], [GermanClass]),
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 -> ([(AccountStatus, Int, CreditHistory, Purpose, Int, Savings, EmploymentStatus, Int, StatusAndSex, OtherDebtors, Int, Property, Int, OtherPlans, Housing, Int, Job, Int, Bool, Bool)], [GermanClass])
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 :: [AccountStatus -> Int -> CreditHistory -> Purpose -> Int -> Savings -> EmploymentStatus -> Int -> StatusAndSex -> OtherDebtors -> Int -> Property -> Int -> OtherPlans -> Housing -> Int -> Job -> Int -> Bool -> Bool -> GermanClass])
return $ zipWith (evalResult ex) trs result
evalResult :: LamdaExecutionEnv -> TypeRequester -> (AccountStatus -> Int -> CreditHistory -> Purpose -> Int -> Savings -> EmploymentStatus -> Int -> StatusAndSex -> OtherDebtors -> Int -> Property -> Int -> OtherPlans -> Housing -> Int -> Job -> Int -> Bool -> Bool -> GermanClass) -> (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, i, j, k, l, m, n, o, p, q, r, s, t) -> result a b c d e f g h i j k l m n o p q r s t) (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)

View File

@@ -1,168 +0,0 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module LambdaDatasets.IrisData
( module LambdaDatasets.IrisDefinition,
module LambdaDatasets.IrisData,
)
where
import LambdaDatasets.IrisDefinition
import Protolude
irisTrainingData :: [((Float, Float, Float, Float), IrisClass)]
irisTrainingData =
[ ((6.7, 3.1, 4.4, 1.4), Versicolor),
((5.4, 3.7, 1.5, 0.2), Setosa),
((5.4, 3.0, 4.5, 1.5), Versicolor),
((5.1, 3.8, 1.5, 0.3), Setosa),
((5.0, 2.3, 3.3, 1.0), Versicolor),
((6.0, 2.7, 5.1, 1.6), Versicolor),
((4.6, 3.2, 1.4, 0.2), Setosa),
((5.6, 2.7, 4.2, 1.3), Versicolor),
((6.7, 3.3, 5.7, 2.1), Virginica),
((6.9, 3.1, 5.1, 2.3), Virginica),
((7.7, 3.8, 6.7, 2.2), Virginica),
((6.1, 2.8, 4.7, 1.2), Versicolor),
((5.8, 2.7, 3.9, 1.2), Versicolor),
((6.7, 3.3, 5.7, 2.5), Virginica),
((5.0, 3.4, 1.5, 0.2), Setosa),
((4.7, 3.2, 1.6, 0.2), Setosa),
((6.8, 3.0, 5.5, 2.1), Virginica),
((6.2, 2.2, 4.5, 1.5), Versicolor),
((5.7, 3.8, 1.7, 0.3), Setosa),
((5.8, 4.0, 1.2, 0.2), Setosa),
((7.2, 3.2, 6.0, 1.8), Virginica),
((5.8, 2.7, 4.1, 1.0), Versicolor),
((6.5, 3.0, 5.8, 2.2), Virginica),
((6.9, 3.2, 5.7, 2.3), Virginica),
((5.8, 2.7, 5.1, 1.9), Virginica),
((5.2, 4.1, 1.5, 0.1), Setosa),
((4.6, 3.6, 1.0, 0.2), Setosa),
((4.7, 3.2, 1.3, 0.2), Setosa),
((6.9, 3.1, 5.4, 2.1), Virginica),
((6.1, 2.9, 4.7, 1.4), Versicolor),
((6.0, 3.4, 4.5, 1.6), Versicolor),
((5.6, 3.0, 4.5, 1.5), Versicolor),
((5.2, 3.4, 1.4, 0.2), Setosa),
((6.3, 3.3, 4.7, 1.6), Versicolor),
((7.2, 3.6, 6.1, 2.5), Virginica),
((6.5, 3.2, 5.1, 2.0), Virginica),
((6.3, 2.5, 4.9, 1.5), Versicolor),
((5.1, 3.8, 1.9, 0.4), Setosa),
((7.0, 3.2, 4.7, 1.4), Versicolor),
((4.9, 3.1, 1.5, 0.1), Setosa),
((4.9, 2.4, 3.3, 1.0), Versicolor),
((6.1, 3.0, 4.9, 1.8), Virginica),
((4.9, 3.1, 1.5, 0.1), Setosa),
((6.2, 2.9, 4.3, 1.3), Versicolor),
((5.7, 3.0, 4.2, 1.2), Versicolor),
((7.2, 3.0, 5.8, 1.6), Virginica),
((5.0, 2.0, 3.5, 1.0), Versicolor),
((4.3, 3.0, 1.1, 0.1), Setosa),
((6.7, 3.1, 4.7, 1.5), Versicolor),
((5.5, 2.4, 3.8, 1.1), Versicolor),
((5.7, 2.8, 4.5, 1.3), Versicolor),
((7.7, 2.8, 6.7, 2.0), Virginica),
((7.6, 3.0, 6.6, 2.1), Virginica),
((4.9, 2.5, 4.5, 1.7), Virginica),
((5.1, 2.5, 3.0, 1.1), Versicolor),
((6.4, 2.8, 5.6, 2.1), Virginica),
((6.4, 2.8, 5.6, 2.2), Virginica),
((5.9, 3.0, 5.1, 1.8), Virginica),
((4.4, 3.2, 1.3, 0.2), Setosa),
((6.3, 2.3, 4.4, 1.3), Versicolor),
((5.4, 3.4, 1.7, 0.2), Setosa),
((4.9, 3.0, 1.4, 0.2), Setosa),
((6.7, 3.0, 5.2, 2.3), Virginica),
((5.0, 3.5, 1.3, 0.3), Setosa),
((5.1, 3.3, 1.7, 0.5), Setosa),
((7.7, 2.6, 6.9, 2.3), Virginica),
((5.6, 2.9, 3.6, 1.3), Versicolor),
((7.3, 2.9, 6.3, 1.8), Virginica),
((6.7, 3.1, 5.6, 2.4), Virginica),
((6.3, 2.8, 5.1, 1.5), Virginica),
((5.6, 2.5, 3.9, 1.1), Versicolor),
((5.4, 3.9, 1.3, 0.4), Setosa),
((5.5, 2.3, 4.0, 1.3), Versicolor),
((6.4, 2.7, 5.3, 1.9), Virginica),
((5.1, 3.5, 1.4, 0.3), Setosa),
((5.5, 3.5, 1.3, 0.2), Setosa),
((5.0, 3.2, 1.2, 0.2), Setosa),
((5.1, 3.4, 1.5, 0.2), Setosa),
((5.4, 3.9, 1.7, 0.4), Setosa),
((4.5, 2.3, 1.3, 0.3), Setosa),
((6.7, 3.0, 5.0, 1.7), Versicolor),
((5.0, 3.3, 1.4, 0.2), Setosa),
((7.1, 3.0, 5.9, 2.1), Virginica),
((5.8, 2.6, 4.0, 1.2), Versicolor),
((6.3, 2.7, 4.9, 1.8), Virginica),
((6.8, 3.2, 5.9, 2.3), Virginica),
((6.6, 3.0, 4.4, 1.4), Versicolor),
((5.4, 3.4, 1.5, 0.4), Setosa),
((5.0, 3.6, 1.4, 0.2), Setosa),
((5.9, 3.2, 4.8, 1.8), Versicolor),
((6.3, 2.5, 5.0, 1.9), Virginica),
((6.0, 3.0, 4.8, 1.8), Virginica),
((7.9, 3.8, 6.4, 2.0), Virginica),
((5.9, 3.0, 4.2, 1.5), Versicolor),
((4.8, 3.0, 1.4, 0.1), Setosa),
((5.7, 2.8, 4.1, 1.3), Versicolor),
((6.7, 2.5, 5.8, 1.8), Virginica),
((5.7, 2.6, 3.5, 1.0), Versicolor),
((4.4, 3.0, 1.3, 0.2), Setosa),
((4.8, 3.4, 1.9, 0.2), Setosa),
((6.3, 3.4, 5.6, 2.4), Virginica),
((5.5, 4.2, 1.4, 0.2), Setosa),
((5.0, 3.0, 1.6, 0.2), Setosa),
((5.7, 2.9, 4.2, 1.3), Versicolor),
((6.2, 2.8, 4.8, 1.8), Virginica),
((6.2, 3.4, 5.4, 2.3), Virginica),
((6.5, 3.0, 5.2, 2.0), Virginica),
((4.9, 3.1, 1.5, 0.1), Setosa),
((5.8, 2.7, 5.1, 1.9), Virginica),
((5.1, 3.5, 1.4, 0.2), Setosa),
((5.6, 2.8, 4.9, 2.0), Virginica),
((5.5, 2.4, 3.7, 1.0), Versicolor),
((6.1, 2.8, 4.0, 1.3), Versicolor),
((5.7, 4.4, 1.5, 0.4), Setosa),
((6.9, 3.1, 4.9, 1.5), Versicolor),
((5.8, 2.8, 5.1, 2.4), Virginica),
((5.7, 2.5, 5.0, 2.0), Virginica),
((6.8, 2.8, 4.8, 1.4), Versicolor),
((6.3, 2.9, 5.6, 1.8), Virginica),
((6.0, 2.2, 4.0, 1.0), Versicolor),
((5.0, 3.5, 1.6, 0.6), Setosa),
((4.6, 3.1, 1.5, 0.2), Setosa),
((4.8, 3.4, 1.6, 0.2), Setosa),
((4.8, 3.0, 1.4, 0.3), Setosa),
((6.4, 2.9, 4.3, 1.3), Versicolor),
((5.5, 2.6, 4.4, 1.2), Versicolor),
((5.2, 2.7, 3.9, 1.4), Versicolor),
((6.0, 2.9, 4.5, 1.5), Versicolor),
((5.3, 3.7, 1.5, 0.2), Setosa),
((6.4, 3.2, 5.3, 2.3), Virginica),
((6.4, 3.1, 5.5, 1.8), Virginica),
((5.1, 3.8, 1.6, 0.2), Setosa),
((5.1, 3.7, 1.5, 0.4), Setosa),
((4.6, 3.4, 1.4, 0.3), Setosa),
((5.6, 3.0, 4.1, 1.3), Versicolor),
((6.1, 3.0, 4.6, 1.4), Versicolor),
((5.2, 3.5, 1.5, 0.2), Setosa),
((7.4, 2.8, 6.1, 1.9), Virginica),
((6.5, 2.8, 4.6, 1.5), Versicolor),
((6.3, 3.3, 6.0, 2.5), Virginica),
((4.8, 3.1, 1.6, 0.2), Setosa),
((7.7, 3.0, 6.1, 2.3), Virginica),
((6.0, 2.2, 5.0, 1.5), Virginica),
((5.5, 2.5, 4.0, 1.3), Versicolor),
((6.5, 3.0, 5.5, 1.8), Virginica),
((4.4, 2.9, 1.4, 0.2), Setosa),
((6.4, 3.2, 4.5, 1.5), Versicolor),
((5.0, 3.4, 1.6, 0.4), Setosa),
((6.1, 2.6, 5.6, 1.4), Virginica),
((6.6, 2.9, 4.6, 1.3), Versicolor)
]

View File

@@ -1,173 +0,0 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module LambdaDatasets.IrisDataset
( module LambdaCalculus,
module LambdaDatasets.IrisDataset,
module LambdaDatasets.IrisData,
module GA,
)
where
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Random
import System.Random.MWC (createSystemRandom)
import Data.Random.Distribution.Uniform
import qualified Data.Text as T
import Data.Tuple.Extra
import GA
import LambdaCalculus
import LambdaDatasets.IrisData
import qualified Language.Haskell.Interpreter as Hint
import qualified Language.Haskell.Interpreter.Unsafe as Hint
import Protolude
import Utils
import Protolude.Error
import qualified Type.Reflection as Ref
lE :: LambdaEnviroment
lE =
LambdaEnviroment
{ functions =
Map.fromList
[ -- Math
((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float))), ["(+)", "(-)", "(*)"]),
-- Logic
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
-- Ordered
((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-- Eq
((Ref.SomeTypeRep (Ref.TypeRep @(IrisClass -> IrisClass -> Bool))), ["(==)","(/=)"]),
-- Any Type
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Float -> Float -> Float))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> IrisClass -> IrisClass -> IrisClass))), ["if'"])
],
constants =
Map.fromList
[ ((Ref.SomeTypeRep (Ref.TypeRep @(Float))), [(fmap show (uniform 0 10 :: RVar Float))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool))), [(fmap show (uniform True False :: RVar Bool))]),
((Ref.SomeTypeRep (Ref.TypeRep @(IrisClass))), [(fmap show (enumUniform Setosa Versicolor :: RVar IrisClass))])
],
targetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
maxDepth = 5,
weights =
ExpressionWeights
{ lambdaSpucker = 10,
lambdaSchlucker = 1,
symbol = 20,
variable = 100,
constant = 5
}
}
lEE :: LamdaExecutionEnv
lEE =
LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports = ["LambdaDatasets.IrisDefinition"],
training = True,
trainingData =
( map fst (takeFraktion 0.8 irisTrainingData),
map snd (takeFraktion 0.8 irisTrainingData)
),
testData =
( map fst (dropFraktion 0.8 irisTrainingData),
map snd (dropFraktion 0.8 irisTrainingData)
),
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
results = Map.empty
}
shuffledLEE :: IO LamdaExecutionEnv
shuffledLEE = do
mwc <- liftIO createSystemRandom
let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
itD <- smpl $ shuffle irisTrainingData
return LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports = ["LambdaDatasets.IrisDefinition"],
training = True,
trainingData =
( map fst (takeFraktion 0.8 itD),
map snd (takeFraktion 0.8 itD)
),
testData =
( map fst (dropFraktion 0.8 itD),
map snd (dropFraktion 0.8 itD)
),
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
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 :: ([(Float, Float, Float, Float)], [IrisClass]),
testData :: ([(Float, Float, Float, Float)], [IrisClass]),
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 -> ([(Float, Float, Float, Float)], [IrisClass])
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 :: [Float -> Float -> Float -> Float -> IrisClass])
return $ zipWith (evalResult ex) trs result
evalResult :: LamdaExecutionEnv -> TypeRequester -> (Float -> Float -> Float -> Float -> IrisClass) -> (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) -> result a b c d) (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)

File diff suppressed because it is too large Load Diff

View File

@@ -1,199 +0,0 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module LambdaDatasets.NurseryDataset
( module LambdaCalculus,
module LambdaDatasets.NurseryDataset,
module LambdaDatasets.NurseryData,
module GA,
)
where
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Random
import Data.Random.Distribution.Uniform
import qualified Data.Text as T
import Data.Tuple.Extra
import GA
import LambdaDatasets.NurseryData
import LambdaCalculus
import qualified Language.Haskell.Interpreter as Hint
import qualified Language.Haskell.Interpreter.Unsafe as Hint
import Protolude
import Protolude.Error
import System.Random.MWC (createSystemRandom)
import qualified Type.Reflection as Ref
import Utils
lE :: LambdaEnviroment
lE =
LambdaEnviroment
{ functions =
Map.fromList
[ -- Math
-- Logic
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
-- Ordered
((Ref.SomeTypeRep (Ref.TypeRep @(NurseryClass -> NurseryClass -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Parents -> Parents -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(HasNurs -> HasNurs -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Form -> Form -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Children -> Children -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Housing -> Housing -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Finance -> Finance -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Social -> Social -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Health -> Health -> Bool))), ["(>)", "(==)", "(/=)", "(>=)"]),
-- Eq
-- Any Type
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Int -> Int -> Int))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> NurseryClass -> NurseryClass -> NurseryClass))), ["if'","if'","if'","if'","if'","if'","if'","if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Parents -> Parents -> Parents))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> HasNurs -> HasNurs -> HasNurs))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Form -> Form -> Form))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Children -> Children -> Children))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Housing -> Housing -> Housing))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Finance -> Finance -> Finance))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Social -> Social -> Social))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Health -> Health -> Health))), ["if'"])
],
constants =
Map.fromList
[ ((Ref.SomeTypeRep (Ref.TypeRep @(Bool))), [(fmap show (uniform True False :: RVar Bool))]),
((Ref.SomeTypeRep (Ref.TypeRep @(NurseryClass))), [(fmap show (enumUniform NotRecommend SpecPriority))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Parents))), [(fmap show (enumUniform Usual GreatPret))]),
((Ref.SomeTypeRep (Ref.TypeRep @(HasNurs))), [(fmap show (enumUniform ProperNurs VeryCritNurs ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Form))), [(fmap show (enumUniform CompleteFamilyForm FosterFamilyForm ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Children))), [(fmap show (enumUniform OneChild MoreChilds ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Housing))), [(fmap show (enumUniform ConvenientHousing CriticalHousing ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Finance))), [(fmap show (enumUniform ConvenientFinance InconvFinance ))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Social))), [(fmap show (enumUniform NotProblematicSocial ProblematicSocial ))]),
((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 = 5,
weights =
ExpressionWeights
{ lambdaSpucker = 10,
lambdaSchlucker = 1,
symbol = 20,
variable = 100,
constant = 5
}
}
trainingFraction :: R
trainingFraction = (2/3)
lEE :: LamdaExecutionEnv
lEE =
LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports = ["LambdaDatasets.NurseryDefinition"],
training = True,
trainingData =
( map fst (takeFraktion trainingFraction 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 = do
mwc <- liftIO createSystemRandom
let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
itD <- smpl $ shuffle nurseryTrainingData
return
LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports = ["LambdaDatasets.NurseryDefinition"],
training = True,
trainingData =
( map fst (takeFraktion trainingFraction itD),
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)

View File

@@ -1,76 +0,0 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
import Options.Applicative
import Pipes
import Pretty
import Protolude hiding (for)
import System.IO
import LambdaDatasets.IrisDataset
-- import LambdaDatasets.NurseryDataset
-- import LambdaDatasets.GermanDataset
import Debug.Trace as DB
import qualified Data.Map.Strict as Map
data Options = Options
{ iterations :: !N,
populationSize :: !N
}
options :: Parser Options
options =
Options
<$> option
auto
( long "iterations"
<> short 'i'
<> metavar "N"
<> value 1500
<> help "Number of iterations"
)
<*> option
auto
( long "population-size"
<> short 'p'
<> metavar "N"
<> value 100
<> help "Population size"
)
optionsWithHelp :: ParserInfo Options
optionsWithHelp =
info
(helper <*> options)
( fullDesc
<> progDesc "Run a GA"
<> header "haga - Haskell implementations of EAs"
)
main :: IO ()
main =
execParser optionsWithHelp >>= \opts -> do
hSetBuffering stdout NoBuffering
lEE <- shuffledLEE
let cfg = GaRunConfig {
enviroment = lE,
initialEvaluator = lEE,
selectionType = Tournament 3,
termination = (steps (iterations opts)),
poulationSize = (populationSize opts),
stepSize = 90,
elitismRatio = 5/100
}
pop' <- runEffect (for (run cfg) logCsv)
lEE' <- calc lEE pop'
let (res, _) = bests lEE' 5 pop'
let lEE' = lEE {training = False}
lEE' <- calc lEE' res
mapM_ (format lEE') res
where
format l s = do
let f = fitness' l s
putErrText $ show f <> "\n" <> pretty s
logCsv = putText . csv
csv (t, f) = show t <> " " <> show f

View File

@@ -1,21 +0,0 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Main where
import qualified GA
import Protolude
main :: IO ()
main = do
_ <- GA.runTests
return ()
if' :: Bool -> a -> a -> a
if' True x _ = x
if' False _ y = y

View File

@@ -1,60 +0,0 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Utils where
import GA (R)
import Protolude
takeFraktion :: (RealFrac f) => f -> [a] -> [a]
takeFraktion frac list = take (floor (frac * (fromIntegral (length list)))) list
dropFraktion :: (RealFrac f) => f -> [a] -> [a]
dropFraktion frac list = drop (floor (frac * (fromIntegral (length list)))) list
meanOfAccuricyPerClass :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
meanOfAccuricyPerClass results = mean $ map (accuracyInClass results) [minBound .. maxBound]
geomeanOfAccuricyPerClass :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
geomeanOfAccuricyPerClass results = geomean $ map (accuracyInClass results) [minBound .. maxBound]
geomeanOfDistributionAccuracy :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
geomeanOfDistributionAccuracy results = geomean $ map (distributionAccuracyForClass results) [minBound .. maxBound]
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
mean :: (Show f, RealFloat f) => [f] -> f
mean values = (sum filteredValues) * (1 / (fromIntegral (length filteredValues)))
where
filteredValues = filter (not . isNaN) values
geomean :: (Show f, RealFloat f) => [f] -> f
geomean values = (product filteredValues) ** (1 / (fromIntegral (length filteredValues)))
where
filteredValues = filter (not . isNaN) values
accuracyInClass :: (Eq r) => [(r, r)] -> r -> R
accuracyInClass results clas = ((accuracy' (inResClass results clas)) * 100) / fromIntegral (length (inClass results clas))
inClass :: (Eq r) => [(r, r)] -> r -> [(r, r)]
inClass results clas = (filter ((clas ==) . fst) results)
inResClass :: (Eq r) => [(r, r)] -> r -> [(r, r)]
inResClass results clas = (filter ((clas ==) . snd) results)
accuracy' :: (Eq r) => [(r, r)] -> R
accuracy' results = fromIntegral $ length (filter (\(target, res) -> (res == target)) results)
repeatedly :: (a -> Maybe a) -> a -> [a]
repeatedly f x = case f x of
Nothing -> []
Just y -> y : repeatedly f y
contains :: (Eq a, Foldable t) => t a -> a -> Bool
contains list val = any (== val) list
count :: (Eq a) => [a] -> a -> Int
count [] _ = 0
count ys find = length xs
where
xs = [xs | xs <- ys, xs == find]

View File

@@ -1,9 +0,0 @@
#!/usr/bin/env bash
#SBATCH --time=18:00:00
#SBATCH --partition=cpu
#SBATCH --array=0-30
#SBATCH --output=./output/output_run_%j.txt
#SBATCH --error=./output/error_run_%j.txt
#SBATCH --nodelist=oc-compute02
#SBATCH --mem=3G
srun nix develop --command stack --no-nix --system-ghc --no-install-ghc run haga-lambda

View File

@@ -1,21 +0,0 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Main where
import Protolude
import qualified Seminar
main :: IO ()
main = do
_ <- Seminar.runTests
return ()
if' :: Bool -> a -> a -> a
if' True x _ = x
if' False _ y = y

View File

@@ -6,11 +6,7 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
-- |
-- Module : GA
-- Description : Abstract genetic algorithm
@@ -24,7 +20,7 @@
-- 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 (..), Fitness (..), Evaluator (..), Individual (..), GA.run, Tournament (..), N, R, Population, steps, bests, runTests, GaRunConfig (..)) where
module GA (Environment, new, population, mutate, crossover1, crossover, nX, Fitness, getR, Evaluator, fitness,fitness', calc, Individual, GA.run, Tournament (..), N, R, Population, steps, bests, runTests) where
import Control.Arrow hiding (first, second)
import Data.List.NonEmpty ((<|))
@@ -35,7 +31,6 @@ import Data.Random
import Pipes
import Pretty
import Protolude
import Protolude.Error
import System.Random.MWC (create, createSystemRandom)
import Test.QuickCheck hiding (sample, shuffle)
import Test.QuickCheck.Instances ()
@@ -51,7 +46,7 @@ type R = Double
-- |
-- An Environment that Individuals of type i can be created from
-- 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 (Pretty e, Individual i) => Environment i e | e -> i where
-- |
-- Generates a completely random individual.
new :: e -> RVar i
@@ -60,7 +55,7 @@ class (Pretty e, Individual i) => Environment i e | e -> i, i -> e where
-- Generates a random population of the given size.
population :: e -> N -> RVar (Population i)
population env n
| n <= 0 = error "nonPositive in population"
| n <= 0 = undefined
| otherwise = NE.fromList <$> replicateM n (new env)
mutate :: e -> i -> RVar i
@@ -88,7 +83,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
-- 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 | i -> e r where
-- |
-- An individual's fitness. Higher values are considered “better”.
--
@@ -97,15 +92,9 @@ class (Individual i, Fitness r) => Evaluator i e r | e -> i r, i -> e where
fitness :: e -> i -> R
fitness env i = getR ( fitness' env i)
-- |
-- An more complete fitness object, used to include more info to the output of the current fitness.
-- You can e.g. track individual size with this.
fitness' :: e -> i -> r
-- |
-- here, fitness values for the next generation can be calculated at once, and just once, using any monadic action, if necessary.
-- 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.
-- TODO kinda hacky?!?
calc :: e -> Population i -> IO e
calc eval _ = do
return eval
@@ -216,25 +205,21 @@ selectBest eval pElite pop nPop = do
then return elitists
else return $ elitists <> (fst $ bests eval (nPop - length elitists) (NE.fromList rest))
-- This class encapsulates everything needed to run a generic genetic Algorithm
data GaRunConfig i r eval env t where
GaRunConfig :: (Individual i, Fitness r, Evaluator i eval r, Environment i env, SelectionType t) => {
enviroment :: env,
initialEvaluator :: eval,
selectionType :: t,
termination :: (Termination i),
poulationSize :: N,
stepSize :: N,
elitismRatio :: R
} -> GaRunConfig i r eval env t
run :: GaRunConfig i r eval env t -> Producer (Int, r) IO (Population i)
run config@(GaRunConfig _ _ _ _ _ _ _) = do
let eval = initialEvaluator config
let env = enviroment config
let nPop = poulationSize config
run ::
(Individual i, Evaluator i eval r, Environment i env, SelectionType s) =>
eval ->
env ->
-- | Mechanism for selecting parents
s ->
-- | Number of parents @nParents@ for creating @nParents@ children
N ->
-- | Elitism ratio @pElite@
R ->
-- | Population size
N ->
Termination i ->
Producer (Int, r) IO (Population i)
run eval env selectionType nParents pElite nPop term = do
mwc <- liftIO createSystemRandom
let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
firstPop <- liftIO $ smpl $ (population env nPop)
@@ -242,17 +227,12 @@ run config@(GaRunConfig _ _ _ _ _ _ _) = do
return res
where
runIter eval count pop smpl = (
if (termination config) pop count
if term pop count
then do
return pop
else do
let env = enviroment config
let nPop = poulationSize config
let selecType = selectionType config
let nParents = stepSize config
let pElite = elitismRatio config
eval <- liftIO $ calc eval pop
withKids <- liftIO $ smpl $ reproduce eval env selecType nParents pop
withKids <- liftIO $ smpl $ reproduce eval env selectionType nParents pop
eval <- liftIO $ calc eval withKids
resPop <- liftIO $ smpl $ selectBest eval pElite withKids nPop
let fBest = fitness' eval $ NE.head $ fst $ bests eval 1 resPop
@@ -286,7 +266,7 @@ tournament1 ::
RVar i
tournament1 eval nTrnmnt pop
-- TODO Use Positive for this constraint
| nTrnmnt <= 0 = error "nonPositive in tournament1"
| nTrnmnt <= 0 = undefined
| otherwise = do
paricipants <- withoutReplacement nTrnmnt pop
return $ NE.head $ fst $ bests eval 1 paricipants
@@ -299,7 +279,7 @@ withoutReplacement ::
N ->
Population i ->
RVar (NonEmpty i)
withoutReplacement 0 _ = error "0 in withoutReplacement"
withoutReplacement 0 _ = undefined
withoutReplacement n pop
| n >= length pop = return pop
| otherwise = fmap (NE.fromList) (shuffleNofM n (length pop) (NE.toList pop))

149
src/IrisDataset.hs Normal file
View File

@@ -0,0 +1,149 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module IrisDataset
( module LambdaCalculus,
module IrisDataset,
module IrisData,
module GA,
)
where
import qualified Data.ByteString.Lazy as B
import Data.Csv
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Random
import Data.Random.Distribution.Uniform
import qualified Data.Text as T
import Data.Tuple.Extra
import qualified Debug.Trace as DB
import GA
import LambdaCalculus
import IrisData
import qualified Language.Haskell.Interpreter as Hint
import qualified Language.Haskell.Interpreter.Unsafe as Hint
import Protolude
import qualified Type.Reflection as Ref
irisLE :: LambdaEnviroment
irisLE =
LambdaEnviroment
{ functions =
Map.fromList
[ ((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float))), ["(+)", "(-)", "(*)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Bool))), ["(>)", "(==)", "(>=)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(IrisClass -> IrisClass -> Bool))), ["(==)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Float -> Float -> Float))), ["if'"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> IrisClass -> IrisClass -> IrisClass))), ["if'"])
],
constants =
Map.fromList
[ ((Ref.SomeTypeRep (Ref.TypeRep @(Float))), [(fmap show (uniform 0 10 :: RVar Float))]),
((Ref.SomeTypeRep (Ref.TypeRep @(Bool))), [(fmap show (uniform True False :: RVar Bool))]),
((Ref.SomeTypeRep (Ref.TypeRep @(IrisClass))), [(fmap show (enumUniform Setosa Versicolor :: RVar IrisClass))])
],
targetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
maxDepth = 10,
weights =
ExpressionWeights
{ lambdaSpucker = 1,
lambdaSchlucker = 1,
symbol = 1,
variable = 2,
constant = 1
}
}
irisLEE :: LamdaExecutionEnv
irisLEE =
LamdaExecutionEnv
{ -- For now these need to define all available functions and types. Generic functions can be used.
imports = ["IrisDataset"],
-- Path to a CSV file containing the training dataset
trainingDataset = "./iris.csv",
-- Path to a CSV file containing the dataset results
trainingDatasetRes = "./res.csv",
trainingData =
( map fst irisTrainingData,
map snd irisTrainingData
),
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
-- todo: kindaHacky
results = Map.empty
}
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,
trainingData :: ([(Float, Float, Float, Float)], [IrisClass]),
exTargetType :: TypeRep,
-- todo: kindaHacky
results :: Map TypeRequester FittnesRes
}
data FittnesRes = FittnesRes
{ total :: R,
fitnessTotal :: R,
fitnessGeoMean :: R,
fitnessMean :: R,
accuracy :: Int,
biasDist :: R,
biasSize :: R
}
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 toAdd = NE.filter (\k -> not (Map.member k (results env))) pop
toInsert <- Hint.runInterpreter (evalResults env toAdd)
let insertPair (key, val) m = Map.insert key val m
let res = foldr insertPair (results env) (fromRight undefined toInsert)
return env {results = res}
evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, FittnesRes)]
evalResults ex trs = mapM (evalResult ex) trs
evalResult :: LamdaExecutionEnv -> TypeRequester -> Hint.InterpreterT IO (TypeRequester, FittnesRes)
evalResult ex tr = do
Hint.setImports $ (map T.unpack (imports ex)) ++ ["Protolude"]
Hint.unsafeSetGhcOption "-O2"
result <- Hint.interpret (T.unpack (toLambdaExpressionS tr)) (Hint.as :: Float -> Float -> Float -> Float -> IrisClass)
let res = map (\(a, b, c, d) -> result a b c d) (fst (trainingData ex))
let resAndTarget = (zip (snd (trainingData ex)) res)
let acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) :: Int
let biasWellDistributed = (foldr (*) 1 (map (\ty -> (foldr (\ts s -> if ((snd ts) == ty) then s + 1 else s) 1 resAndTarget)) ([minBound .. maxBound] :: [IrisClass]) :: [R])) ** (1 / 3) -- 1 (schlecht) bis 51 (gut)
let biasSmall = exp (-(fromIntegral (countTrsR tr))) -- 0 (schlecht) bis 1 (gut)
let fitness' = meanOfAccuricyPerClass resAndTarget
let score = fitness' + (biasSmall - 1)
return
( tr,
FittnesRes
{ total = score,
fitnessTotal = fitness',
fitnessMean = meanOfAccuricyPerClass resAndTarget,
fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
accuracy = acc,
biasDist = biasWellDistributed,
biasSize = biasSmall
}
)
if' :: Bool -> a -> a -> a
if' True e _ = e
if' False _ e = e

View File

@@ -9,7 +9,7 @@
module LambdaCalculus where
import Data.List (foldr1, intersect, last, nub, (!!), (\\))
import Data.List (foldr1, last)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Maybe
@@ -17,15 +17,12 @@ import Data.Random
import qualified Data.Text as T
import Data.Tuple.Extra
import Data.Typeable
import Debug.Trace as DB
import GA
import Pretty
import Protolude
import Protolude.Error
import Test.QuickCheck hiding (sample, shuffle)
import Test.QuickCheck.Monadic (assert, monadicIO)
import qualified Type.Reflection as Ref
import Utils
data ExpressionWeights = ExpressionWeights
{ lambdaSpucker :: Int,
@@ -74,6 +71,7 @@ exampleLE =
type BoundVars = [TypeRep]
-- we need a dynamic typ with a concept of equality here, should we want to interpret the result, instead of compiling it...
type ConVal = Text
@@ -94,7 +92,7 @@ toLambdaExpressionS :: TypeRequester -> Text
toLambdaExpressionS (TR typeRep (Just lambdaExpression) boundVars) = "((" <> eToLambdaExpressionS lambdaExpression <> ") :: (" <> show typeRep <> "))"
toLambdaExpressionS (TR _ (Nothing) _) = "Invalid Lambda Epr"
-- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show)
-- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int | Constan ConVal
eToLambdaExpressionS :: LambdaExpression -> Text
eToLambdaExpressionS (LambdaSpucker typeRequester1 typeRequester2 boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionS typeRequester2 <> ") " <> toLambdaExpressionS typeRequester1
@@ -178,7 +176,7 @@ genLambdaSchlucker env@(LambdaEnviroment functions constants _ _ weights) depthL
let args = typeRepArgs target
let lambaType = fromJust (head args)
let toFind = last args
typeRequester <- genTypeRequester env (depthLeft + 1) toFind (boundVar ++ [lambaType])
typeRequester <- genTypeRequester env depthLeft toFind (boundVar ++ [lambaType])
return (LambdaSchlucker typeRequester (boundVar ++ [lambaType]))
genLambdaConst :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
@@ -233,148 +231,62 @@ instance Environment TypeRequester LambdaEnviroment where
return tr
mutate env@(LambdaEnviroment _ _ _ maxDepth _) tr = do
selfCrossover <- uniform True False
co <- crossover1 env tr tr
if selfCrossover && isJust co
then do
let (tr1, tr2) = fromJust co
return $ minimumBy (compare `on` countTrsR) [tr1, tr2]
else 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
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
nX _ = 3 -- todo!
crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do
let trCount = countTrsR tr1
selectedIndex1 <- uniform 1 trCount
let (depthAt1, selectedTr1@(TR _ _ bound1)) = depthLeftAndTypeAtR tr1 selectedIndex1 maxDepth
let depthLeftNeeded = depthOfTR selectedTr1
let indexes = findIndicesWhere tr2 (isCompatibleTr selectedTr1 (maxDepth - depthAt1) depthLeftNeeded) 0 0
if length indexes == 0
then return Nothing
else
( do
(selectedTr2@(TR _ _ bound2), selectedIndex2) <- randomElement indexes
selectedTr2 <- adaptBoundVars selectedTr2 bound1
selectedTr1 <- adaptBoundVars selectedTr1 bound2
let child1 = replaceAtR selectedIndex1 tr1 selectedTr2
let child2 = replaceAtR selectedIndex2 tr2 selectedTr1
return $ Just (child1, child2)
)
return Nothing
-- TODO: crossover!
-- 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)
-- helper
depthOfTR :: TypeRequester -> Int
depthOfTR (TR _ (Just le@(LambdaSchlucker _ _)) _) = maximum (0:(map depthOfTR (asList le)))
depthOfTR (TR _ (Just le) _) = maximum (0:(map depthOfTR (asList le))) + 1
depthOfTR _ = error "le Not Just (depthOfTR)"
adaptBoundVars :: TypeRequester -> BoundVars -> RVar TypeRequester
adaptBoundVars tr@(TR _ _ bvOld) bvNew = do
newIndexMap <- generateConversionIndexMap bvOld bvNew
return $ convertTr tr bvOld bvNew newIndexMap
-- 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
convertTr :: TypeRequester -> BoundVars -> BoundVars -> Map TypeRep (Int -> Int) -> TypeRequester
convertTr tr@(TR tRp (Just le) bvCurr) bvOld bvNew mapper = TR tRp (Just (convertLe le bvOld bvNew mapper)) (bvNew ++ (bvCurr \\ bvOld))
convertTr _ _ _ _ = error "le Not Just (convertTr)"
-- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show)
convertLe :: LambdaExpression -> BoundVars -> BoundVars -> Map TypeRep (Int -> Int) -> LambdaExpression
convertLe (LambdaSpucker tr1 tr2 bvCurr) bvOld bvNew mapper = LambdaSpucker (convertTrf tr1) (convertTrf tr2) (bvNew ++ (bvCurr \\ bvOld))
where
convertTrf tr = convertTr tr bvOld bvNew mapper
convertLe (LambdaSchlucker tr bvCurr) bvOld bvNew mapper = LambdaSchlucker (convertTrf tr) (bvNew ++ (bvCurr \\ bvOld))
where
convertTrf tr = convertTr tr bvOld bvNew mapper
convertLe (Symbol cv trs bvCurr) bvOld bvNew mapper = Symbol cv (map convertTrf trs) (bvNew ++ (bvCurr \\ bvOld))
where
convertTrf tr = convertTr tr bvOld bvNew mapper
convertLe (Var varType varNumber trs bvCurr) bvOld bvNew mapper = Var varType ((fromMaybe identity (Map.lookup varType mapper)) varNumber) (map convertTrf trs) (bvNew ++ (bvCurr \\ bvOld))
where
convertTrf tr = convertTr tr bvOld bvNew mapper
convertLe le@(Constan _) _ _ _ = le
generateConversionIndexMap :: BoundVars -> BoundVars -> RVar (Map TypeRep (Int -> Int))
generateConversionIndexMap bvOld bvNew = do
funcs <- mapM (\bT -> genMapper (count bvOld bT - 1) (count bvNew bT - 1)) (nub bvOld)
return $ Map.fromList $ zip (nub bvOld) funcs
genMapper :: Int -> Int -> RVar (Int -> Int)
genMapper i j
| i == j = return identity
| i < j = return $ \int -> if int <= i then int else int + (j - i)
| i > j = do
permutationForUnbound <- genPermutation i j
return $ genMapperRandomAssment i j permutationForUnbound
| otherwise = error "impossible case in genMapper"
genMapperRandomAssment :: Int -> Int -> [Int] -> Int -> Int
genMapperRandomAssment i j permutationForUnbound int
| int <= j = int
| int > i = int - (i - j)
| otherwise = permutationForUnbound !! (int - j - 1)
genPermutation :: Int -> Int -> RVar [Int]
genPermutation i j = replicateM (i - j) (uniform 0 j)
isCompatibleTr :: TypeRequester -> Int -> Int -> TypeRequester -> Int -> Bool
isCompatibleTr tr1@(TR trep1 _ bound1) maxDepthOfTR2 maxDepthOfNode tr2@(TR trep2 _ bound2) depthOfNode
| trep1 == trep2 = allUsedBound (usedVars bound1 tr1) bound2 && allUsedBound (usedVars bound2 tr2) bound1 && maxDepthOfTR2 >= (depthOfTR tr2) && maxDepthOfNode >= depthOfNode
| otherwise = False
allUsedBound :: BoundVars -> BoundVars -> Bool
allUsedBound used available = all (\x -> any (== x) available) used
usedVars :: BoundVars -> TypeRequester -> BoundVars
usedVars boundOld tr@(TR trep1 (Just (Var trp ind trs _)) _) = if any (== trp) boundOld && count boundOld trp > ind then trp : concatMap (usedVars boundOld) trs else concatMap (usedVars boundOld) trs
usedVars boundOld tr@(TR trep1 (Just le) _) = concatMap (usedVars boundOld) (asList le)
usedVars _ _ = error "Nothing in usedVars"
boundsConvertable :: BoundVars -> BoundVars -> Bool
boundsConvertable bv1 bv2 = length (nub bv2) == length (nub bv1) && length (intersect (nub bv1) bv2) == length (nub bv1)
findIndicesWhere :: TypeRequester -> (TypeRequester -> Int -> Bool) -> Int -> Int -> [(TypeRequester, Int)]
findIndicesWhere tr@(TR _ (Just le@(LambdaSchlucker _ _)) _) filte indx currDepth = if filte tr currDepth then (tr, indx + 1) : (findIndicesWhere' (asList le) filte (indx + 1) (currDepth)) else (findIndicesWhere' (asList le) filte (indx + 1) (currDepth))
findIndicesWhere tr@(TR _ lE _) filte indx currDepth = case lE of
Just le -> if filte tr currDepth then (tr, indx + 1) : (findIndicesWhere' (asList le) filte (indx + 1) (currDepth + 1)) else (findIndicesWhere' (asList le) filte (indx + 1) (currDepth + 1))
Nothing -> error "Nothing in findIndicesWhere"
findIndicesWhere' :: [TypeRequester] -> (TypeRequester -> Int -> Bool) -> Int -> Int -> [(TypeRequester, Int)]
findIndicesWhere' [] _ _ _ = []
findIndicesWhere' [tr] f indx currDepth = (findIndicesWhere tr f indx currDepth)
findIndicesWhere' (tr : trs) f indx currDepth = (findIndicesWhere tr f indx currDepth) ++ (findIndicesWhere' trs f (indx + countTrsR tr) currDepth)
-- findIndicesWhere':: [TypeRequester] -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)]
-- findIndicesWhere' (tr:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr))
replaceAtR :: Int -> TypeRequester -> TypeRequester -> TypeRequester
replaceAtR 1 _ with = with
replaceAtR i (TR tm (Just le) bV) with = TR tm (Just (replaceAt (i - 1) le with)) bV
replaceAtR _ (TR _ Nothing _) _ = error "Nothing in replaceAtR"
replaceAtR _ (TR _ Nothing _) _ = undefined
replaceAt :: Int -> LambdaExpression -> TypeRequester -> LambdaExpression
replaceAt i le@(LambdaSpucker _ _ bv) with = LambdaSpucker (fromJust (head trs)) (last trs) bv where trs = replaceInSubtreeWithIndex i (asList le) with
replaceAt i (LambdaSchlucker tr bv) with = LambdaSchlucker (replaceAtR i tr with) bv
replaceAt i le@(Symbol cv _ bv) with = Symbol cv trs bv where trs = replaceInSubtreeWithIndex i (asList le) with
replaceAt i le@(Var tr ix _ bv) with = Var tr ix trs bv where trs = replaceInSubtreeWithIndex i (asList le) with
replaceAt _ (Constan _) _ = error "Nothing in replaceAt"
replaceAt _ (Constan _) _ = undefined
replaceInSubtreeWithIndex :: Int -> [TypeRequester] -> TypeRequester -> [TypeRequester]
replaceInSubtreeWithIndex indexLeft (tr : trs) with = if countTrsR tr >= indexLeft then (replaceAtR indexLeft tr with) : trs else tr : (replaceInSubtreeWithIndex (indexLeft - countTrsR tr) trs with)
replaceInSubtreeWithIndex _ [] _ = error "Index not found in replaceInSubtreeWithIndex"
replaceInSubtreeWithIndex _ [] _ = undefined
depthLeftAndTypeAtR :: TypeRequester -> Int -> Int -> (Int, TypeRequester)
depthLeftAndTypeAtR t 1 depthLeft = ((depthLeft - 1), t)
depthLeftAndTypeAtR (TR _ (Just le) _) indexLeft depthLeft = depthLeftAndTypeAt le (indexLeft - 1) (depthLeft - 1)
depthLeftAndTypeAtR (TR _ Nothing _) indexLeft depthLeft = error "Nothing in depthLeftAndTypeAtR"
depthLeftAndTypeAtR (TR _ Nothing _) indexLeft depthLeft = undefined
depthLeftAndTypeAt :: LambdaExpression -> Int -> Int -> (Int, TypeRequester)
depthLeftAndTypeAt le@(LambdaSchlucker tr bv) indexLeft depthLeft = depthLeftAndTypeInSubtreeWithIndex (asList le) indexLeft (depthLeft + 1)
depthLeftAndTypeAt le indexLeft depthLeft = depthLeftAndTypeInSubtreeWithIndex (asList le) indexLeft depthLeft
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 = error "Index not found in depthLeftAndTypeInSubtreeWithIndex"
depthLeftAndTypeInSubtreeWithIndex [] indexLeft depthLeft = undefined
countTrsR :: TypeRequester -> Int
countTrsR tr@(TR t lE _) = case lE of
@@ -384,6 +296,17 @@ countTrsR tr@(TR t lE _) = case lE of
countTrs :: LambdaExpression -> Int
countTrs le = sum (map countTrsR (asList le))
repeatedly :: (a -> Maybe a) -> a -> [a]
repeatedly f x = case f x of
Nothing -> []
Just y -> y : repeatedly f y
count :: (Eq a) => [a] -> a -> Int
count [] find = 0
count ys find = length xs
where
xs = [xs | xs <- ys, xs == find]
-- Test Stuff
testConstInt :: TypeRequester
@@ -543,3 +466,34 @@ eToLambdaExpressionShort (Constan (valS)) = valS
res :: Int -> ResClass
res = ((\lInt0 -> ((iteClass ((eqInt ((lInt0) :: (Int)) ((1) :: (Int))) :: (Bool)) ((Class1) :: (ResClass)) ((iteClass ((eqInt ((lInt0) :: (Int)) ((2) :: (Int))) :: (Bool)) ((Class2) :: (ResClass)) ((iteClass ((eqInt ((lInt0) :: (Int)) ((3) :: (Int))) :: (Bool)) ((Class3) :: (ResClass)) ((Class3) :: (ResClass))) :: (ResClass))) :: (ResClass))) :: (ResClass))) :: (Int -> ResClass))
meanOfAccuricyPerClass :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
meanOfAccuricyPerClass results = mean $ map (accuracyInClass results) [minBound .. maxBound]
geomeanOfAccuricyPerClass :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
geomeanOfAccuricyPerClass results = geomean $ map (accuracyInClass results) [minBound .. maxBound]
geomeanOfDistributionAccuracy :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
geomeanOfDistributionAccuracy results = geomean $ map (distributionAccuracyForClass results) [minBound .. maxBound]
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
mean :: (Show f, Floating f) => [f] -> f
mean values = (sum values) * (1 / (fromIntegral (length values)))
geomean :: (Show f, Floating f) => [f] -> f
geomean values = (product values) ** (1 / (fromIntegral (length values)))
accuracyInClass :: (Eq r) => [(r, r)] -> r -> R
accuracyInClass results clas = ((accuracy'(inResClass results clas)) * 100) / fromIntegral (length (inClass results clas))
inClass :: (Eq r) => [(r, r)] -> r -> [(r, r)]
inClass results clas = (filter ((clas ==) . fst) results)
inResClass :: (Eq r) => [(r, r)] -> r -> [(r, r)]
inResClass results clas = (filter ((clas ==) . snd) results)
accuracy' :: (Eq r) => [(r, r)] -> R
accuracy' results = fromIntegral $ length (filter (\(target, res) -> (res == target)) results)

View File

@@ -7,8 +7,9 @@ import Pipes
import Pretty
import Protolude hiding (for)
import System.IO
import Seminar
import Szenario191
-- import Szenario212Pun
-- import Szenario191
import IrisDataset
data Options = Options
{ iterations :: !N,
@@ -23,7 +24,7 @@ options =
( long "iterations"
<> short 'i'
<> metavar "N"
<> value 1500
<> value 1000
<> help "Number of iterations"
)
<*> option
@@ -31,7 +32,7 @@ options =
( long "population-size"
<> short 'p'
<> metavar "N"
<> value 400
<> value 50
<> help "Population size"
)
@@ -48,23 +49,18 @@ main :: IO ()
main =
execParser optionsWithHelp >>= \opts -> do
hSetBuffering stdout NoBuffering
let cfg = GaRunConfig {
enviroment = AssignmentEnviroment (students prios, topics prios),
initialEvaluator = prios,
selectionType = Tournament 3,
termination = (steps (iterations opts)),
poulationSize = (populationSize opts),
stepSize = 120,
elitismRatio = 5/100
}
pop' <- runEffect (for (run cfg) logCsv)
prios' <- calc prios pop'
let (res, _) = bests prios' 5 pop'
prios' <- calc prios' res
mapM_ (format prios') res
let env = irisLE
let selType = Tournament 3
let run' = run irisLEE env selType 40 (5 / 100) (populationSize opts) (steps (iterations opts))
pop' <-
runEffect (for run' logCsv)
irisLE <- calc irisLEE pop'
let (res, _) = bests irisLE 5 pop'
mapM_ (format irisLE) res
where
format seminarL s = do
let f = fitness' seminarL s
format irisL s = do
let f = fitness' irisL s
putErrText $ show f <> "\n" <> pretty s
logCsv = putText . csv
csv (t, f) = show t <> " " <> show f

View File

@@ -127,6 +127,8 @@ instance Environment Assignment AssignmentEnviroment where
-- Borrowed from TSP: Crossover cuts the parents in two and swaps them (if this
-- does not create an invalid offspring).
--
-- TODO Assumes that both individuals are based on the same priorities.
--
crossover1 e assignment1 assignment2 = do
let l = fromIntegral $ min (length assignment1) (length assignment2) :: Double
x <- uniform 0 l

39
src/Test.hs Normal file
View File

@@ -0,0 +1,39 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Main where
import Data.Random
import Data.Typeable
import qualified GA
import qualified LambdaCalculus
import Protolude
import qualified Seminar
import System.Random.MWC (createSystemRandom)
import qualified Type.Reflection as Ref
main :: IO ()
main = do
-- _ <- GA.runTests
-- _ <- Seminar.runTests
-- _ <- putStrLn $ ((show (typeRepArgs (Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int -> Text))))) :: Text)
-- _ <- putStrLn $ ((show (typeRepArgs (Ref.SomeTypeRep (Ref.TypeRep @(Text))))) :: Text)
mwc <- createSystemRandom
r <- sampleFrom mwc $ GA.new LambdaCalculus.exampleLE
_ <- putStrLn $ LambdaCalculus.toLambdaExpressionS $ r
r <- sampleFrom mwc $ GA.new LambdaCalculus.exampleLE
_ <- putStrLn $ LambdaCalculus.toLambdaExpressionS $ r
-- _ <- putStrLn (LambdaCalculus.toLambdaExpressionShort LambdaCalculus.testIntToClassCorrect)
-- _ <- putStrLn $ ((show (LambdaCalculus.res 1)) :: Text)
-- _ <- putStrLn $ ((show (LambdaCalculus.res 2)) :: Text)
-- _ <- putStrLn $ ((show (LambdaCalculus.res 3)) :: Text)
return ()
if' :: Bool -> a -> a -> a
if' True x _ = x
if' False _ y = y