clean up, organize and document
This commit is contained in:
parent
5945016607
commit
ea687a2fbb
63
haga.cabal
63
haga.cabal
|
@ -1,4 +1,4 @@
|
|||
cabal-version: 2.2
|
||||
cabal-version: 3.4
|
||||
name: haga
|
||||
version: 0.1.0.0
|
||||
synopsis: Simplistic genetic algorithms library
|
||||
|
@ -43,23 +43,25 @@ library
|
|||
, text
|
||||
, wl-pprint-text
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
|
||||
hs-source-dirs: src
|
||||
ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -O2
|
||||
hs-source-dirs: lib, lambda/lib
|
||||
other-modules: CommonDefinition
|
||||
exposed-modules: GA
|
||||
, Seminar
|
||||
, Pretty
|
||||
, Szenario191
|
||||
, LambdaCalculus
|
||||
, NurseryDataset
|
||||
, NurseryData
|
||||
, Pretty
|
||||
, Utils
|
||||
executable haga
|
||||
, LambdaDatasets.NurseryDefinition
|
||||
, LambdaDatasets.GermanDefinition
|
||||
, LambdaDatasets.IrisDefinition
|
||||
|
||||
executable haga-lambda
|
||||
build-depends: base
|
||||
, bytestring
|
||||
, cassava
|
||||
, containers
|
||||
, extra
|
||||
, hint
|
||||
, haga
|
||||
, monad-loops
|
||||
, MonadRandom
|
||||
, mwc-random
|
||||
|
@ -78,16 +80,32 @@ executable haga
|
|||
, wl-pprint-text
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
|
||||
hs-source-dirs: src
|
||||
hs-source-dirs: lambda/src
|
||||
main-is: Main.hs
|
||||
other-modules: GA
|
||||
, Seminar
|
||||
, Pretty
|
||||
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
|
||||
, Szenario191
|
||||
, LambdaCalculus
|
||||
, NurseryDataset
|
||||
, NurseryData
|
||||
, Utils
|
||||
|
||||
executable haga-test
|
||||
build-depends: base
|
||||
|
@ -96,6 +114,7 @@ executable haga-test
|
|||
, cassava
|
||||
, containers
|
||||
, extra
|
||||
, haga
|
||||
, hint
|
||||
, monad-loops
|
||||
, MonadRandom
|
||||
|
@ -115,13 +134,5 @@ executable haga-test
|
|||
, wl-pprint-text
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
|
||||
hs-source-dirs: src
|
||||
hs-source-dirs: lib
|
||||
main-is: Test.hs
|
||||
other-modules: GA
|
||||
, Seminar
|
||||
, Pretty
|
||||
, Szenario191
|
||||
, LambdaCalculus
|
||||
, NurseryDataset
|
||||
, NurseryData
|
||||
, Utils
|
||||
|
|
17
lambda/README.md
Normal file
17
lambda/README.md
Normal file
|
@ -0,0 +1,17 @@
|
|||
# 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
|
||||
```
|
9
lambda/lib/CommonDefinition.hs
Normal file
9
lambda/lib/CommonDefinition.hs
Normal file
|
@ -0,0 +1,9 @@
|
|||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module CommonDefinition where
|
||||
|
||||
import Protolude
|
||||
|
||||
if' :: Bool -> a -> a -> a
|
||||
if' True e _ = e
|
||||
if' False _ e = e
|
38
lambda/lib/LambdaDatasets/GermanDefinition.hs
Normal file
38
lambda/lib/LambdaDatasets/GermanDefinition.hs
Normal file
|
@ -0,0 +1,38 @@
|
|||
{-# 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)
|
16
lambda/lib/LambdaDatasets/IrisDefinition.hs
Normal file
16
lambda/lib/LambdaDatasets/IrisDefinition.hs
Normal file
|
@ -0,0 +1,16 @@
|
|||
{-# 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)
|
||||
|
32
lambda/lib/LambdaDatasets/NurseryDefinition.hs
Normal file
32
lambda/lib/LambdaDatasets/NurseryDefinition.hs
Normal file
|
@ -0,0 +1,32 @@
|
|||
{-# 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)
|
||||
|
|
@ -1,36 +1,13 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module GermanData where
|
||||
module LambdaDatasets.GermanData
|
||||
( module LambdaDatasets.GermanDefinition,
|
||||
module LambdaDatasets.GermanData,
|
||||
)
|
||||
where
|
||||
|
||||
import Protolude
|
||||
|
||||
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)
|
||||
import LambdaDatasets.GermanDefinition
|
||||
|
||||
germanTrainingData :: [((AccountStatus, Int, CreditHistory, Purpose, Int, Savings, EmploymentStatus, Int, StatusAndSex, OtherDebtors, Int, Property, Int, OtherPlans, Housing, Int, Job, Int, Bool, Bool), GermanClass)]
|
||||
germanTrainingData =
|
|
@ -4,10 +4,10 @@
|
|||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module GermanDataset
|
||||
module LambdaDatasets.GermanDataset
|
||||
( module LambdaCalculus,
|
||||
module GermanDataset,
|
||||
module GermanData,
|
||||
module LambdaDatasets.GermanDataset,
|
||||
module LambdaDatasets.GermanData,
|
||||
module GA,
|
||||
)
|
||||
where
|
||||
|
@ -19,7 +19,7 @@ import Data.Random.Distribution.Uniform
|
|||
import qualified Data.Text as T
|
||||
import Data.Tuple.Extra
|
||||
import GA
|
||||
import GermanData
|
||||
import LambdaDatasets.GermanData
|
||||
import LambdaCalculus
|
||||
import qualified Language.Haskell.Interpreter as Hint
|
||||
import qualified Language.Haskell.Interpreter.Unsafe as Hint
|
||||
|
@ -29,8 +29,8 @@ import System.Random.MWC (createSystemRandom)
|
|||
import qualified Type.Reflection as Ref
|
||||
import Utils
|
||||
|
||||
germanLE :: LambdaEnviroment
|
||||
germanLE =
|
||||
lE :: LambdaEnviroment
|
||||
lE =
|
||||
LambdaEnviroment
|
||||
{ functions =
|
||||
Map.fromList
|
||||
|
@ -90,18 +90,18 @@ germanLE =
|
|||
weights =
|
||||
ExpressionWeights
|
||||
{ lambdaSpucker = 1,
|
||||
lambdaSchlucker = 1,
|
||||
lambdaSchlucker = 2,
|
||||
symbol = 30,
|
||||
variable = 10,
|
||||
constant = 5
|
||||
}
|
||||
}
|
||||
|
||||
germanLEE :: LamdaExecutionEnv
|
||||
germanLEE =
|
||||
lEE :: LamdaExecutionEnv
|
||||
lEE =
|
||||
LamdaExecutionEnv
|
||||
{ -- For now these need to define all available functions and types. Generic functions can be used.
|
||||
imports = ["GermanDataset"],
|
||||
imports = ["LambdaDatasets.GermanDefinition"],
|
||||
training = True,
|
||||
trainingData =
|
||||
( map fst (takeFraktion 0.8 germanTrainingData),
|
||||
|
@ -115,15 +115,15 @@ germanLEE =
|
|||
results = Map.empty
|
||||
}
|
||||
|
||||
shuffledGermanLEE :: IO LamdaExecutionEnv
|
||||
shuffledGermanLEE = do
|
||||
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 = ["GermanDataset"],
|
||||
imports = ["LambdaDatasets.GermanDefinition"],
|
||||
training = True,
|
||||
trainingData =
|
||||
( map fst (takeFraktion 0.8 itD),
|
||||
|
@ -177,21 +177,17 @@ dset :: LamdaExecutionEnv -> ([(AccountStatus, Int, CreditHistory, Purpose, Int,
|
|||
dset lEE = if training lEE then trainingData lEE else testData lEE
|
||||
|
||||
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
|
||||
evalResults ex trs = do
|
||||
Hint.setImports $ (map T.unpack (imports ex)) ++ ["Protolude"]
|
||||
Hint.unsafeSetGhcOption "-O2"
|
||||
result <- Hint.interpret (T.unpack (toLambdaExpressionS tr)) (Hint.as :: AccountStatus -> Int -> CreditHistory -> Purpose -> Int -> Savings -> EmploymentStatus -> Int -> StatusAndSex -> OtherDebtors -> Int -> Property -> Int -> OtherPlans -> Housing -> Int -> Job -> Int -> Bool -> Bool -> GermanClass)
|
||||
let 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))
|
||||
let resAndTarget = (zip (snd (dset ex)) res)
|
||||
let acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) / fromIntegral (length resAndTarget)
|
||||
let biasSmall = exp ((-(fromIntegral (countTrsR tr))) / 1000) -- 0 (schlecht) bis 1 (gut)
|
||||
let fitness' = meanOfAccuricyPerClass resAndTarget
|
||||
let score = fitness' + (biasSmall - 1)
|
||||
return
|
||||
( tr,
|
||||
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 = score,
|
||||
fitnessTotal = fitness',
|
||||
|
@ -202,7 +198,11 @@ evalResult ex tr = do
|
|||
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)
|
||||
|
||||
if' :: Bool -> a -> a -> a
|
||||
if' True e _ = e
|
||||
if' False _ e = e
|
|
@ -4,17 +4,15 @@
|
|||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module IrisData where
|
||||
module LambdaDatasets.IrisData
|
||||
( module LambdaDatasets.IrisDefinition,
|
||||
module LambdaDatasets.IrisData,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Csv
|
||||
import LambdaDatasets.IrisDefinition
|
||||
import Protolude
|
||||
|
||||
data IrisClass = Setosa | Virginica | Versicolor deriving (Eq, Generic, Show, Enum, Bounded)
|
||||
|
||||
instance FromRecord IrisClass
|
||||
|
||||
instance ToRecord IrisClass
|
||||
|
||||
irisTrainingData :: [((Float, Float, Float, Float), IrisClass)]
|
||||
irisTrainingData =
|
||||
[ ((6.7, 3.1, 4.4, 1.4), Versicolor),
|
||||
|
@ -168,4 +166,3 @@ irisTrainingData =
|
|||
((6.1, 2.6, 5.6, 1.4), Virginica),
|
||||
((6.6, 2.9, 4.6, 1.3), Versicolor)
|
||||
]
|
||||
|
|
@ -4,10 +4,10 @@
|
|||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module IrisDataset
|
||||
module LambdaDatasets.IrisDataset
|
||||
( module LambdaCalculus,
|
||||
module IrisDataset,
|
||||
module IrisData,
|
||||
module LambdaDatasets.IrisDataset,
|
||||
module LambdaDatasets.IrisData,
|
||||
module GA,
|
||||
)
|
||||
where
|
||||
|
@ -21,7 +21,7 @@ import qualified Data.Text as T
|
|||
import Data.Tuple.Extra
|
||||
import GA
|
||||
import LambdaCalculus
|
||||
import IrisData
|
||||
import LambdaDatasets.IrisData
|
||||
import qualified Language.Haskell.Interpreter as Hint
|
||||
import qualified Language.Haskell.Interpreter.Unsafe as Hint
|
||||
import Protolude
|
||||
|
@ -29,8 +29,8 @@ import Utils
|
|||
import Protolude.Error
|
||||
import qualified Type.Reflection as Ref
|
||||
|
||||
irisLE :: LambdaEnviroment
|
||||
irisLE =
|
||||
lE :: LambdaEnviroment
|
||||
lE =
|
||||
LambdaEnviroment
|
||||
{ functions =
|
||||
Map.fromList
|
||||
|
@ -59,11 +59,11 @@ irisLE =
|
|||
}
|
||||
}
|
||||
|
||||
irisLEE :: LamdaExecutionEnv
|
||||
irisLEE =
|
||||
lEE :: LamdaExecutionEnv
|
||||
lEE =
|
||||
LamdaExecutionEnv
|
||||
{ -- For now these need to define all available functions and types. Generic functions can be used.
|
||||
imports = ["IrisDataset"],
|
||||
imports = ["LambdaDatasets.IrisDataset"],
|
||||
training = True,
|
||||
trainingData =
|
||||
( map fst (takeFraktion 0.8 irisTrainingData),
|
||||
|
@ -77,14 +77,14 @@ irisLEE =
|
|||
results = Map.empty
|
||||
}
|
||||
|
||||
shuffledIrisLEE :: IO LamdaExecutionEnv
|
||||
shuffledIrisLEE = do
|
||||
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 = ["IrisDataset"],
|
||||
imports = ["LambdaDatasets.IrisDataset"],
|
||||
training = True,
|
||||
trainingData =
|
||||
( map fst (takeFraktion 0.8 itD),
|
||||
|
@ -138,21 +138,17 @@ 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 = mapM (evalResult ex) trs
|
||||
|
||||
evalResult :: LamdaExecutionEnv -> TypeRequester -> Hint.InterpreterT IO (TypeRequester, FittnesRes)
|
||||
evalResult ex tr = do
|
||||
evalResults ex trs = 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 (dset ex))
|
||||
let resAndTarget = (zip (snd (dset ex)) res)
|
||||
let acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) / fromIntegral (length resAndTarget)
|
||||
let biasSmall = exp ((-(fromIntegral (countTrsR tr)))/1000) -- 0 (schlecht) bis 1 (gut)
|
||||
let fitness' = meanOfAccuricyPerClass resAndTarget
|
||||
let score = fitness' + (biasSmall - 1)
|
||||
return
|
||||
( tr,
|
||||
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 = score,
|
||||
fitnessTotal = fitness',
|
||||
|
@ -163,8 +159,10 @@ evalResult ex tr = do
|
|||
totalSize = countTrsR tr
|
||||
}
|
||||
)
|
||||
|
||||
if' :: Bool -> a -> a -> a
|
||||
if' True e _ = e
|
||||
if' False _ e = e
|
||||
|
||||
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)
|
|
@ -4,27 +4,14 @@
|
|||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module NurseryData where
|
||||
module LambdaDatasets.NurseryData
|
||||
( module LambdaDatasets.NurseryDefinition,
|
||||
module LambdaDatasets.NurseryData,
|
||||
)
|
||||
where
|
||||
|
||||
import Protolude
|
||||
|
||||
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)
|
||||
import LambdaDatasets.NurseryDefinition
|
||||
|
||||
nurseryTrainingData :: [((Parents, HasNurs, Form, Children, Housing, Finance, Social, Health), NurseryClass)]
|
||||
nurseryTrainingData =
|
|
@ -4,10 +4,10 @@
|
|||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module NurseryDataset
|
||||
module LambdaDatasets.NurseryDataset
|
||||
( module LambdaCalculus,
|
||||
module NurseryDataset,
|
||||
module NurseryData,
|
||||
module LambdaDatasets.NurseryDataset,
|
||||
module LambdaDatasets.NurseryData,
|
||||
module GA,
|
||||
)
|
||||
where
|
||||
|
@ -19,7 +19,7 @@ import Data.Random.Distribution.Uniform
|
|||
import qualified Data.Text as T
|
||||
import Data.Tuple.Extra
|
||||
import GA
|
||||
import NurseryData
|
||||
import LambdaDatasets.NurseryData
|
||||
import LambdaCalculus
|
||||
import qualified Language.Haskell.Interpreter as Hint
|
||||
import qualified Language.Haskell.Interpreter.Unsafe as Hint
|
||||
|
@ -29,8 +29,8 @@ import System.Random.MWC (createSystemRandom)
|
|||
import qualified Type.Reflection as Ref
|
||||
import Utils
|
||||
|
||||
nurseryLE :: LambdaEnviroment
|
||||
nurseryLE =
|
||||
lE :: LambdaEnviroment
|
||||
lE =
|
||||
LambdaEnviroment
|
||||
{ functions =
|
||||
Map.fromList
|
||||
|
@ -74,52 +74,55 @@ nurseryLE =
|
|||
((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 = 7,
|
||||
maxDepth = 8,
|
||||
weights =
|
||||
ExpressionWeights
|
||||
{ lambdaSpucker = 2,
|
||||
lambdaSchlucker = 1,
|
||||
{ lambdaSpucker = 1,
|
||||
lambdaSchlucker = 2,
|
||||
symbol = 30,
|
||||
variable = 20,
|
||||
constant = 5
|
||||
}
|
||||
}
|
||||
|
||||
nurseryLEE :: LamdaExecutionEnv
|
||||
nurseryLEE =
|
||||
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 = ["NurseryDataset"],
|
||||
imports = ["LambdaDatasets.NurseryDefinition"],
|
||||
training = True,
|
||||
trainingData =
|
||||
( map fst (takeFraktion (2/3) nurseryTrainingData),
|
||||
map snd (takeFraktion (2/3) nurseryTrainingData)
|
||||
( map fst (takeFraktion trainingFraction nurseryTrainingData),
|
||||
map snd (takeFraktion trainingFraction nurseryTrainingData)
|
||||
),
|
||||
testData =
|
||||
( map fst (dropFraktion (2/3) nurseryTrainingData),
|
||||
map snd (dropFraktion (2/3) nurseryTrainingData)
|
||||
( 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
|
||||
}
|
||||
|
||||
shuffledNurseryLEE :: IO LamdaExecutionEnv
|
||||
shuffledNurseryLEE = do
|
||||
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 = ["NurseryDataset"],
|
||||
imports = ["LambdaDatasets.NurseryDefinition"],
|
||||
training = True,
|
||||
trainingData =
|
||||
( map fst (takeFraktion (2/3) itD),
|
||||
map snd (takeFraktion (2/3) itD)
|
||||
( map fst (takeFraktion trainingFraction itD),
|
||||
map snd (takeFraktion trainingFraction itD)
|
||||
),
|
||||
testData =
|
||||
( map fst (dropFraktion (2/3) itD),
|
||||
map snd (dropFraktion (2/3) itD)
|
||||
( 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
|
||||
|
@ -194,7 +197,3 @@ evalResult ex tr result = ( tr,
|
|||
fitness' = meanOfAccuricyPerClass resAndTarget
|
||||
score = fitness' + (biasSmall - 1)
|
||||
|
||||
|
||||
if' :: Bool -> a -> a -> a
|
||||
if' True e _ = e
|
||||
if' False _ e = e
|
|
@ -7,9 +7,9 @@ import Pipes
|
|||
import Pretty
|
||||
import Protolude hiding (for)
|
||||
import System.IO
|
||||
-- import Szenario212Pun
|
||||
-- import Szenario191
|
||||
import NurseryDataset
|
||||
-- import LambdaDatasets.IrisDataset
|
||||
-- import LambdaDatasets.NurseryDataset
|
||||
import LambdaDatasets.GermanDataset
|
||||
import Debug.Trace as DB
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
|
@ -26,7 +26,7 @@ options =
|
|||
( long "iterations"
|
||||
<> short 'i'
|
||||
<> metavar "N"
|
||||
<> value 5000
|
||||
<> value 1500
|
||||
<> help "Number of iterations"
|
||||
)
|
||||
<*> option
|
||||
|
@ -51,19 +51,19 @@ main :: IO ()
|
|||
main =
|
||||
execParser optionsWithHelp >>= \opts -> do
|
||||
hSetBuffering stdout NoBuffering
|
||||
nurseryLEE <- shuffledNurseryLEE
|
||||
let env = nurseryLE
|
||||
lEE <- shuffledLEE
|
||||
let env = lE
|
||||
let selType = Tournament 3
|
||||
let run' = run nurseryLEE env selType 120 (5 / 100) (populationSize opts) (steps (iterations opts))
|
||||
let run' = run lEE env selType 120 (5 / 100) (populationSize opts) (steps (iterations opts))
|
||||
pop' <- runEffect (for run' logCsv)
|
||||
nurseryLEE' <- calc nurseryLEE pop'
|
||||
let (res, _) = bests nurseryLEE' 5 pop'
|
||||
let nurseryLEE' = nurseryLEE {training = False}
|
||||
nurseryLEE' <- calc nurseryLEE' res
|
||||
mapM_ (format nurseryLEE') res
|
||||
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 nurseryL s = do
|
||||
let f = fitness' nurseryL s
|
||||
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
|
|
@ -93,9 +93,15 @@ class (Individual i, Fitness r) => Evaluator i e r | i -> e r 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
|
||||
|
||||
-- TODO kinda hacky?!?
|
||||
-- |
|
||||
-- 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.
|
||||
calc :: e -> Population i -> IO e
|
||||
calc eval _ = do
|
||||
return eval
|
21
lib/Test.hs
Normal file
21
lib/Test.hs
Normal file
|
@ -0,0 +1,21 @@
|
|||
{-# 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
|
|
@ -23,14 +23,18 @@ geomeanOfDistributionAccuracy results = geomean $ map (distributionAccuracyForCl
|
|||
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)))
|
||||
mean :: (Show f, RealFloat f) => [f] -> f
|
||||
mean values = (sum filteredValues) * (1 / (fromIntegral (length filteredValues)))
|
||||
where
|
||||
filteredValues = filter (not . isNaN) values
|
||||
|
||||
geomean :: (Show f, Floating f) => [f] -> f
|
||||
geomean values = (product values) ** (1 / (fromIntegral (length 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 = if fromIntegral (length (inClass results clas)) == 0 then 100 else ((accuracy' (inResClass results clas)) * 100) / fromIntegral (length (inClass results clas))
|
||||
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)
|
||||
|
@ -50,7 +54,7 @@ contains :: (Eq a, Foldable t ) => t a -> a -> Bool
|
|||
contains list val = any (== val) list
|
||||
|
||||
count :: (Eq a) => [a] -> a -> Int
|
||||
count [] find = 0
|
||||
count [] _ = 0
|
||||
count ys find = length xs
|
||||
where
|
||||
xs = [xs | xs <- ys, xs == find]
|
|
@ -6,4 +6,4 @@
|
|||
#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
|
||||
srun nix develop --command stack --no-nix --system-ghc --no-install-ghc run haga-lambda
|
||||
|
|
65
src-students/Main.hs
Normal file
65
src-students/Main.hs
Normal file
|
@ -0,0 +1,65 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
import Options.Applicative
|
||||
import Pipes
|
||||
import Pretty
|
||||
import Protolude hiding (for)
|
||||
import System.IO
|
||||
import Seminar
|
||||
import Szenario191
|
||||
|
||||
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 400
|
||||
<> 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
|
||||
let seminarEE = prios
|
||||
let env = AssignmentEnviroment (students seminarEE, topics seminarEE)
|
||||
let selType = Tournament 3
|
||||
let run' = run seminarEE env selType 120 (5 / 100) (populationSize opts) (steps (iterations opts))
|
||||
pop' <- runEffect (for run' logCsv)
|
||||
seminarEE' <- calc seminarEE pop'
|
||||
let (res, _) = bests seminarEE' 5 pop'
|
||||
seminarEE' <- calc seminarEE' res
|
||||
mapM_ (format seminarEE') res
|
||||
where
|
||||
format seminarL s = do
|
||||
let f = fitness' seminarL s
|
||||
putErrText $ show f <> "\n" <> pretty s
|
||||
logCsv = putText . csv
|
||||
csv (t, f) = show t <> " " <> show f
|
|
@ -127,8 +127,6 @@ 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
|
21
src-students/Test.hs
Normal file
21
src-students/Test.hs
Normal file
|
@ -0,0 +1,21 @@
|
|||
{-# 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
|
|
@ -1,177 +0,0 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module IrisData where
|
||||
|
||||
import Data.Csv
|
||||
import Protolude
|
||||
|
||||
data IrisClass = Setosa | Virginica | Versicolor deriving (Eq, Generic, Show, Enum, Bounded)
|
||||
|
||||
instance FromRecord IrisClass
|
||||
|
||||
instance ToRecord IrisClass
|
||||
|
||||
irisData :: [((Float, Float, Float, Float), IrisClass)]
|
||||
irisData =
|
||||
[
|
||||
((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),
|
||||
((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),
|
||||
]
|
||||
|
||||
irisTestData :: [((Float, Float, Float, Float), IrisClass)]
|
||||
irisTestData =
|
||||
[
|
||||
|
||||
]
|
39
src/Test.hs
39
src/Test.hs
|
@ -1,39 +0,0 @@
|
|||
{-# 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
|
Loading…
Reference in New Issue
Block a user