Compare commits
1 Commits
german_cos
...
c261fcdfbb
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
c261fcdfbb |
@@ -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
8
flake.lock
generated
@@ -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"
|
||||
}
|
||||
},
|
||||
|
||||
11
flake.nix
11
flake.nix
@@ -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
|
||||
];
|
||||
};
|
||||
};
|
||||
|
||||
64
haga.cabal
64
haga.cabal
@@ -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
|
||||
|
||||
@@ -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
|
||||
```
|
||||
@@ -1,9 +0,0 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module CommonDefinition where
|
||||
|
||||
import Protolude
|
||||
|
||||
if' :: Bool -> a -> a -> a
|
||||
if' True e _ = e
|
||||
if' False _ e = e
|
||||
@@ -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)
|
||||
@@ -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)
|
||||
|
||||
@@ -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
@@ -1,211 +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 = 9,
|
||||
weights =
|
||||
ExpressionWeights
|
||||
{ lambdaSpucker = 0,
|
||||
lambdaSchlucker = 10,
|
||||
symbol = 100,
|
||||
variable = 5,
|
||||
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,
|
||||
costAccordingToDataset :: N,
|
||||
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 = (biasSmall - 1) - (fromIntegral costAccordingToDS),
|
||||
fitnessTotal = fitness',
|
||||
costAccordingToDataset = costAccordingToDS,
|
||||
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 (\(actual,predicted) s -> if (actual == predicted) then s + 1 else s) 0 resAndTarget) / fromIntegral (length resAndTarget)
|
||||
costAccordingToDS = (foldr (\(actual,predicted) s -> if ((actual) == (predicted)) then s else (if actual == Deny then s+5 else s+1)) 0 resAndTarget)
|
||||
biasSmall = exp ((-(fromIntegral (countTrsR tr))) / 1000) -- 0 (schlecht) bis 1 (gut)
|
||||
fitness' = meanOfAccuricyPerClass resAndTarget
|
||||
score = fitness' + (biasSmall - 1)
|
||||
|
||||
@@ -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)
|
||||
]
|
||||
@@ -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 = 9,
|
||||
weights =
|
||||
ExpressionWeights
|
||||
{ lambdaSpucker = 0,
|
||||
lambdaSchlucker = 10,
|
||||
symbol = 100,
|
||||
variable = 5,
|
||||
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
@@ -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 = 9,
|
||||
weights =
|
||||
ExpressionWeights
|
||||
{ lambdaSpucker = 0,
|
||||
lambdaSchlucker = 10,
|
||||
symbol = 100,
|
||||
variable = 5,
|
||||
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)
|
||||
|
||||
@@ -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
|
||||
21
lib/Test.hs
21
lib/Test.hs
@@ -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
|
||||
60
lib/Utils.hs
60
lib/Utils.hs
@@ -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]
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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
149
src/IrisDataset.hs
Normal 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
|
||||
|
||||
@@ -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,13 +231,6 @@ 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
|
||||
@@ -249,132 +240,53 @@ instance Environment TypeRequester LambdaEnviroment where
|
||||
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)
|
||||
@@ -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
|
||||
@@ -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
39
src/Test.hs
Normal 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
|
||||
Reference in New Issue
Block a user