implement Iris dataset
This commit is contained in:
Johannes Merl
parent
57cf1452bf
commit
6435f4aca2
10
src/GA.hs
10
src/GA.hs
|
|
@ -35,6 +35,7 @@ import System.Random.MWC (create, createSystemRandom)
|
|||
import Test.QuickCheck hiding (sample, shuffle)
|
||||
import Test.QuickCheck.Instances ()
|
||||
import Test.QuickCheck.Monadic
|
||||
import Debug.Trace as DB
|
||||
|
||||
-- TODO there should be a few 'shuffle's here
|
||||
|
||||
|
|
@ -170,7 +171,7 @@ reproduce ::
|
|||
Population i ->
|
||||
RVar (Population i)
|
||||
reproduce eval env selectT nParents pop = do
|
||||
iParents <- select selectT nParents pop eval
|
||||
iParents <-select selectT nParents pop eval
|
||||
iChildren <- NE.filter (`notElem` pop) <$> children env iParents
|
||||
let pop' = pop `NE.appendl` iChildren
|
||||
return pop'
|
||||
|
|
@ -214,13 +215,10 @@ 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)
|
||||
_ <- liftIO $ putText $ pretty $ NE.head firstPop
|
||||
firstPop <- liftIO $ smpl $ (population env nPop)
|
||||
_ <- liftIO $ putText $ pretty $ NE.head firstPop
|
||||
res <- runIter eval 0 firstPop smpl
|
||||
return res
|
||||
where
|
||||
runIter eval count pop smpl =
|
||||
runIter eval count pop smpl = (
|
||||
if term pop count
|
||||
then do
|
||||
return pop
|
||||
|
|
@ -232,7 +230,7 @@ run eval env selectionType nParents pElite nPop term = do
|
|||
let fBest = fitness eval $ NE.head $ fst $ bests eval 1 resPop
|
||||
Pipes.yield (count, fBest)
|
||||
res <- runIter eval (count + 1) resPop smpl
|
||||
return res
|
||||
return res)
|
||||
|
||||
-- * Selection mechanisms
|
||||
|
||||
|
|
|
|||
438
src/IrisDataset.hs
Normal file
438
src/IrisDataset.hs
Normal file
|
|
@ -0,0 +1,438 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module IrisDataset
|
||||
( module LambdaCalculus,
|
||||
module IrisDataset,
|
||||
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 qualified Language.Haskell.Interpreter as Hint
|
||||
import qualified Language.Haskell.Interpreter.Unsafe as Hint
|
||||
import Protolude
|
||||
import qualified Type.Reflection as Ref
|
||||
|
||||
data IrisClass = Setosa | Virginica | Versicolor deriving (Eq, Generic, Show, Enum, Bounded)
|
||||
|
||||
instance FromRecord IrisClass
|
||||
|
||||
instance ToRecord IrisClass
|
||||
|
||||
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 =
|
||||
( [ (5.1, 3.5, 1.4, 0.2),
|
||||
(4.9, 3.0, 1.4, 0.2),
|
||||
(4.7, 3.2, 1.3, 0.2),
|
||||
(4.6, 3.1, 1.5, 0.2),
|
||||
(5.0, 3.6, 1.4, 0.2),
|
||||
(5.4, 3.9, 1.7, 0.4),
|
||||
(4.6, 3.4, 1.4, 0.3),
|
||||
(5.0, 3.4, 1.5, 0.2),
|
||||
(4.4, 2.9, 1.4, 0.2),
|
||||
(4.9, 3.1, 1.5, 0.1),
|
||||
(5.4, 3.7, 1.5, 0.2),
|
||||
(4.8, 3.4, 1.6, 0.2),
|
||||
(4.8, 3.0, 1.4, 0.1),
|
||||
(4.3, 3.0, 1.1, 0.1),
|
||||
(5.8, 4.0, 1.2, 0.2),
|
||||
(5.7, 4.4, 1.5, 0.4),
|
||||
(5.4, 3.9, 1.3, 0.4),
|
||||
(5.1, 3.5, 1.4, 0.3),
|
||||
(5.7, 3.8, 1.7, 0.3),
|
||||
(5.1, 3.8, 1.5, 0.3),
|
||||
(5.4, 3.4, 1.7, 0.2),
|
||||
(5.1, 3.7, 1.5, 0.4),
|
||||
(4.6, 3.6, 1.0, 0.2),
|
||||
(5.1, 3.3, 1.7, 0.5),
|
||||
(4.8, 3.4, 1.9, 0.2),
|
||||
(5.0, 3.0, 1.6, 0.2),
|
||||
(5.0, 3.4, 1.6, 0.4),
|
||||
(5.2, 3.5, 1.5, 0.2),
|
||||
(5.2, 3.4, 1.4, 0.2),
|
||||
(4.7, 3.2, 1.6, 0.2),
|
||||
(4.8, 3.1, 1.6, 0.2),
|
||||
(5.4, 3.4, 1.5, 0.4),
|
||||
(5.2, 4.1, 1.5, 0.1),
|
||||
(5.5, 4.2, 1.4, 0.2),
|
||||
(4.9, 3.1, 1.5, 0.1),
|
||||
(5.0, 3.2, 1.2, 0.2),
|
||||
(5.5, 3.5, 1.3, 0.2),
|
||||
(4.9, 3.1, 1.5, 0.1),
|
||||
(4.4, 3.0, 1.3, 0.2),
|
||||
(5.1, 3.4, 1.5, 0.2),
|
||||
(5.0, 3.5, 1.3, 0.3),
|
||||
(4.5, 2.3, 1.3, 0.3),
|
||||
(4.4, 3.2, 1.3, 0.2),
|
||||
(5.0, 3.5, 1.6, 0.6),
|
||||
(5.1, 3.8, 1.9, 0.4),
|
||||
(4.8, 3.0, 1.4, 0.3),
|
||||
(5.1, 3.8, 1.6, 0.2),
|
||||
(4.6, 3.2, 1.4, 0.2),
|
||||
(5.3, 3.7, 1.5, 0.2),
|
||||
(5.0, 3.3, 1.4, 0.2),
|
||||
(7.0, 3.2, 4.7, 1.4),
|
||||
(6.4, 3.2, 4.5, 1.5),
|
||||
(6.9, 3.1, 4.9, 1.5),
|
||||
(5.5, 2.3, 4.0, 1.3),
|
||||
(6.5, 2.8, 4.6, 1.5),
|
||||
(5.7, 2.8, 4.5, 1.3),
|
||||
(6.3, 3.3, 4.7, 1.6),
|
||||
(4.9, 2.4, 3.3, 1.0),
|
||||
(6.6, 2.9, 4.6, 1.3),
|
||||
(5.2, 2.7, 3.9, 1.4),
|
||||
(5.0, 2.0, 3.5, 1.0),
|
||||
(5.9, 3.0, 4.2, 1.5),
|
||||
(6.0, 2.2, 4.0, 1.0),
|
||||
(6.1, 2.9, 4.7, 1.4),
|
||||
(5.6, 2.9, 3.6, 1.3),
|
||||
(6.7, 3.1, 4.4, 1.4),
|
||||
(5.6, 3.0, 4.5, 1.5),
|
||||
(5.8, 2.7, 4.1, 1.0),
|
||||
(6.2, 2.2, 4.5, 1.5),
|
||||
(5.6, 2.5, 3.9, 1.1),
|
||||
(5.9, 3.2, 4.8, 1.8),
|
||||
(6.1, 2.8, 4.0, 1.3),
|
||||
(6.3, 2.5, 4.9, 1.5),
|
||||
(6.1, 2.8, 4.7, 1.2),
|
||||
(6.4, 2.9, 4.3, 1.3),
|
||||
(6.6, 3.0, 4.4, 1.4),
|
||||
(6.8, 2.8, 4.8, 1.4),
|
||||
(6.7, 3.0, 5.0, 1.7),
|
||||
(6.0, 2.9, 4.5, 1.5),
|
||||
(5.7, 2.6, 3.5, 1.0),
|
||||
(5.5, 2.4, 3.8, 1.1),
|
||||
(5.5, 2.4, 3.7, 1.0),
|
||||
(5.8, 2.7, 3.9, 1.2),
|
||||
(6.0, 2.7, 5.1, 1.6),
|
||||
(5.4, 3.0, 4.5, 1.5),
|
||||
(6.0, 3.4, 4.5, 1.6),
|
||||
(6.7, 3.1, 4.7, 1.5),
|
||||
(6.3, 2.3, 4.4, 1.3),
|
||||
(5.6, 3.0, 4.1, 1.3),
|
||||
(5.5, 2.5, 4.0, 1.3),
|
||||
(5.5, 2.6, 4.4, 1.2),
|
||||
(6.1, 3.0, 4.6, 1.4),
|
||||
(5.8, 2.6, 4.0, 1.2),
|
||||
(5.0, 2.3, 3.3, 1.0),
|
||||
(5.6, 2.7, 4.2, 1.3),
|
||||
(5.7, 3.0, 4.2, 1.2),
|
||||
(5.7, 2.9, 4.2, 1.3),
|
||||
(6.2, 2.9, 4.3, 1.3),
|
||||
(5.1, 2.5, 3.0, 1.1),
|
||||
(5.7, 2.8, 4.1, 1.3),
|
||||
(6.3, 3.3, 6.0, 2.5),
|
||||
(5.8, 2.7, 5.1, 1.9),
|
||||
(7.1, 3.0, 5.9, 2.1),
|
||||
(6.3, 2.9, 5.6, 1.8),
|
||||
(6.5, 3.0, 5.8, 2.2),
|
||||
(7.6, 3.0, 6.6, 2.1),
|
||||
(4.9, 2.5, 4.5, 1.7),
|
||||
(7.3, 2.9, 6.3, 1.8),
|
||||
(6.7, 2.5, 5.8, 1.8),
|
||||
(7.2, 3.6, 6.1, 2.5),
|
||||
(6.5, 3.2, 5.1, 2.0),
|
||||
(6.4, 2.7, 5.3, 1.9),
|
||||
(6.8, 3.0, 5.5, 2.1),
|
||||
(5.7, 2.5, 5.0, 2.0),
|
||||
(5.8, 2.8, 5.1, 2.4),
|
||||
(6.4, 3.2, 5.3, 2.3),
|
||||
(6.5, 3.0, 5.5, 1.8),
|
||||
(7.7, 3.8, 6.7, 2.2),
|
||||
(7.7, 2.6, 6.9, 2.3),
|
||||
(6.0, 2.2, 5.0, 1.5),
|
||||
(6.9, 3.2, 5.7, 2.3),
|
||||
(5.6, 2.8, 4.9, 2.0),
|
||||
(7.7, 2.8, 6.7, 2.0),
|
||||
(6.3, 2.7, 4.9, 1.8),
|
||||
(6.7, 3.3, 5.7, 2.1),
|
||||
(7.2, 3.2, 6.0, 1.8),
|
||||
(6.2, 2.8, 4.8, 1.8),
|
||||
(6.1, 3.0, 4.9, 1.8),
|
||||
(6.4, 2.8, 5.6, 2.1),
|
||||
(7.2, 3.0, 5.8, 1.6),
|
||||
(7.4, 2.8, 6.1, 1.9),
|
||||
(7.9, 3.8, 6.4, 2.0),
|
||||
(6.4, 2.8, 5.6, 2.2),
|
||||
(6.3, 2.8, 5.1, 1.5),
|
||||
(6.1, 2.6, 5.6, 1.4),
|
||||
(7.7, 3.0, 6.1, 2.3),
|
||||
(6.3, 3.4, 5.6, 2.4),
|
||||
(6.4, 3.1, 5.5, 1.8),
|
||||
(6.0, 3.0, 4.8, 1.8),
|
||||
(6.9, 3.1, 5.4, 2.1),
|
||||
(6.7, 3.1, 5.6, 2.4),
|
||||
(6.9, 3.1, 5.1, 2.3),
|
||||
(5.8, 2.7, 5.1, 1.9),
|
||||
(6.8, 3.2, 5.9, 2.3),
|
||||
(6.7, 3.3, 5.7, 2.5),
|
||||
(6.7, 3.0, 5.2, 2.3),
|
||||
(6.3, 2.5, 5.0, 1.9),
|
||||
(6.5, 3.0, 5.2, 2.0),
|
||||
(6.2, 3.4, 5.4, 2.3),
|
||||
(5.9, 3.0, 5.1, 1.8)
|
||||
],
|
||||
[ Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Setosa,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Versicolor,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica,
|
||||
Virginica
|
||||
]
|
||||
),
|
||||
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 R
|
||||
}
|
||||
|
||||
instance Evaluator TypeRequester LamdaExecutionEnv where
|
||||
fitness env tr = (results env) Map.! tr
|
||||
|
||||
calc env pop = do
|
||||
let toAdd = NE.filter (\k -> not (Map.member k (results env))) pop
|
||||
env <- loadTrainingData env
|
||||
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}
|
||||
|
||||
loadTrainingData :: LamdaExecutionEnv -> IO LamdaExecutionEnv
|
||||
loadTrainingData ex@LamdaExecutionEnv {trainingData = ([], [])} = do
|
||||
csv <- B.readFile (trainingDataset ex)
|
||||
let dat = (toList $ fromRight undefined $ decode NoHeader csv) :: [(Float, Float, Float, Float)]
|
||||
csvRes <- B.readFile (trainingDatasetRes ex)
|
||||
let decodedRes = decode NoHeader csvRes
|
||||
let recsRes = (toList $ fromRight undefined decodedRes) :: [IrisClass]
|
||||
return ex {trainingData = (dat, recsRes)}
|
||||
loadTrainingData lee@LamdaExecutionEnv {trainingData = (_ : _, _ : _)} = return lee
|
||||
loadTrainingData lee@LamdaExecutionEnv {trainingData = (_ : _, [])} = return undefined
|
||||
loadTrainingData lee@LamdaExecutionEnv {trainingData = ([], _ : _)} = return undefined
|
||||
|
||||
evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, R)]
|
||||
evalResults ex trs = mapM (evalResult ex) trs
|
||||
|
||||
evalResult :: LamdaExecutionEnv -> TypeRequester -> Hint.InterpreterT IO (TypeRequester, R)
|
||||
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) :: R
|
||||
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)
|
||||
let biasSmall = exp ( - (fromIntegral (countTrsR tr)))
|
||||
let score = acc + (biasWellDistributed/5.1) + (biasSmall)
|
||||
return (tr, score)
|
||||
|
||||
if' :: Bool -> a -> a -> a
|
||||
if' True e _ = e
|
||||
if' False _ e = e
|
||||
|
|
@ -62,21 +62,22 @@ exampleLE =
|
|||
weights =
|
||||
ExpressionWeights
|
||||
{ lambdaSpucker = 1,
|
||||
lambdaSchlucker = 1,
|
||||
symbol = 1,
|
||||
variable = 1,
|
||||
constant = 1
|
||||
lambdaSchlucker = 2,
|
||||
symbol = 2,
|
||||
variable = 10,
|
||||
constant = 2
|
||||
}
|
||||
}
|
||||
|
||||
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
|
||||
|
||||
-- LambdaSpucker - adds TypeRequester#1 as bound var and returns the result of TypeRequester#2
|
||||
|
||||
data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord)
|
||||
data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show)
|
||||
|
||||
asList :: LambdaExpression -> [TypeRequester]
|
||||
asList (LambdaSpucker tr1 tr2 _) = [tr1, tr2]
|
||||
|
|
@ -85,7 +86,7 @@ asList (Symbol _ trs _) = trs
|
|||
asList (Var _ _ trs _) = trs
|
||||
asList (Constan _) = []
|
||||
|
||||
data TypeRequester = TR TypeRep (Maybe LambdaExpression) BoundVars deriving (Eq, Ord)
|
||||
data TypeRequester = TR TypeRep (Maybe LambdaExpression) BoundVars deriving (Eq, Ord, Show)
|
||||
|
||||
toLambdaExpressionS :: TypeRequester -> Text
|
||||
toLambdaExpressionS (TR typeRep (Just lambdaExpression) boundVars) = "((" <> eToLambdaExpressionS lambdaExpression <> ") :: (" <> show typeRep <> "))"
|
||||
|
|
@ -163,7 +164,7 @@ doTypesMatch toGen available = elem toGen (available : (repeatedly (lastMay . ty
|
|||
|
||||
genLambdaSpucker :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
|
||||
genLambdaSpucker env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do
|
||||
lamdaTypeLength <- uniform 1 3
|
||||
lamdaTypeLength <- uniform 1 4
|
||||
lambaTypes <- replicateM lamdaTypeLength (randomElement (Map.keys constants))
|
||||
let lambaType = foldr1 mkFunTy lambaTypes
|
||||
lamdaVarTypeRequester <- genTypeRequester env depthLeft lambaType boundVar
|
||||
|
|
@ -260,7 +261,7 @@ instance Environment TypeRequester LambdaEnviroment where
|
|||
-- findIndicesWhere' (tr:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr))
|
||||
|
||||
replaceAtR :: Int -> TypeRequester -> TypeRequester -> TypeRequester
|
||||
replaceAtR 0 _ with = with
|
||||
replaceAtR 1 _ with = with
|
||||
replaceAtR i (TR tm (Just le) bV) with = TR tm (Just (replaceAt (i - 1) le with)) bV
|
||||
replaceAtR _ (TR _ Nothing _) _ = undefined
|
||||
|
||||
|
|
@ -276,7 +277,7 @@ replaceInSubtreeWithIndex indexLeft (tr : trs) with = if countTrsR tr >= indexLe
|
|||
replaceInSubtreeWithIndex _ [] _ = undefined
|
||||
|
||||
depthLeftAndTypeAtR :: TypeRequester -> Int -> Int -> (Int, TypeRequester)
|
||||
depthLeftAndTypeAtR t 0 depthLeft = ((depthLeft - 1), t)
|
||||
depthLeftAndTypeAtR t 1 depthLeft = ((depthLeft - 1), t)
|
||||
depthLeftAndTypeAtR (TR _ (Just le) _) indexLeft depthLeft = depthLeftAndTypeAt le (indexLeft - 1) (depthLeft - 1)
|
||||
depthLeftAndTypeAtR (TR _ Nothing _) indexLeft depthLeft = undefined
|
||||
|
||||
|
|
@ -458,7 +459,7 @@ toLambdaExpressionShort (TR _ (Nothing) _) = "Invalid Lambda Epr"
|
|||
|
||||
eToLambdaExpressionShort :: LambdaExpression -> Text
|
||||
eToLambdaExpressionShort (LambdaSpucker typeRequester1 typeRequester2 boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionShort typeRequester2 <> ") " <> toLambdaExpressionShort typeRequester1
|
||||
eToLambdaExpressionShort (LambdaSchlucker typeRequester boundVars) = "()\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionShort typeRequester <> ")"
|
||||
eToLambdaExpressionShort (LambdaSchlucker typeRequester boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionShort typeRequester <> ")"
|
||||
eToLambdaExpressionShort (Symbol (valS) typeRequesters _) = valS <> " " <> (unwords (map toLambdaExpressionShort typeRequesters))
|
||||
eToLambdaExpressionShort (Var typeRep int typeRequesters _) = "l" <> showSanifid typeRep <> show int <> " " <> (unwords (map toLambdaExpressionShort typeRequesters))
|
||||
eToLambdaExpressionShort (Constan (valS)) = valS
|
||||
|
|
|
|||
19
src/Main.hs
19
src/Main.hs
|
|
@ -8,7 +8,8 @@ import Pretty
|
|||
import Protolude hiding (for)
|
||||
import System.IO
|
||||
-- import Szenario212Pun
|
||||
import Szenario191
|
||||
-- import Szenario191
|
||||
import IrisDataset
|
||||
|
||||
data Options = Options
|
||||
{ iterations :: !N,
|
||||
|
|
@ -48,16 +49,18 @@ main :: IO ()
|
|||
main =
|
||||
execParser optionsWithHelp >>= \opts -> do
|
||||
hSetBuffering stdout NoBuffering
|
||||
let env = AssignmentEnviroment (students prios, topics prios)
|
||||
let selType = Tournament 20
|
||||
let run' = run prios env selType 20 (5 / 100) (populationSize opts) (steps (iterations opts)) :: Producer (Int, R) IO (Population Assignment)
|
||||
let env = irisLE
|
||||
let selType = Tournament 3
|
||||
let run' = run irisLEE env selType 40 (5 / 100) (populationSize opts) (steps (iterations opts)) :: Producer (Int, R) IO (Population TypeRequester)
|
||||
pop' <-
|
||||
runEffect (for run' logCsv)
|
||||
let (res, _) = bests prios 5 pop'
|
||||
mapM_ format res
|
||||
|
||||
irisLE <- calc irisLEE pop'
|
||||
let (res, _) = bests irisLE 5 pop'
|
||||
mapM_ (format irisLE) res
|
||||
where
|
||||
format s = do
|
||||
let f = fitness prios 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user