Compare commits
2 Commits
4d40050f1a
...
4286ee36d9
| Author | SHA1 | Date | |
|---|---|---|---|
|
4286ee36d9 | ||
|
|
f891229937 |
|
|
@ -31,6 +31,7 @@ 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 ()
|
||||
|
|
@ -55,7 +56,7 @@ class (Pretty e, Individual i) => Environment i e | e -> i where
|
|||
-- Generates a random population of the given size.
|
||||
population :: e -> N -> RVar (Population i)
|
||||
population env n
|
||||
| n <= 0 = undefined
|
||||
| n <= 0 = error "nonPositive in population"
|
||||
| otherwise = NE.fromList <$> replicateM n (new env)
|
||||
|
||||
mutate :: e -> i -> RVar i
|
||||
|
|
@ -266,7 +267,7 @@ tournament1 ::
|
|||
RVar i
|
||||
tournament1 eval nTrnmnt pop
|
||||
-- TODO Use Positive for this constraint
|
||||
| nTrnmnt <= 0 = undefined
|
||||
| nTrnmnt <= 0 = error "nonPositive in tournament1"
|
||||
| otherwise = do
|
||||
paricipants <- withoutReplacement nTrnmnt pop
|
||||
return $ NE.head $ fst $ bests eval 1 paricipants
|
||||
|
|
@ -279,7 +280,7 @@ withoutReplacement ::
|
|||
N ->
|
||||
Population i ->
|
||||
RVar (NonEmpty i)
|
||||
withoutReplacement 0 _ = undefined
|
||||
withoutReplacement 0 _ = error "0 in withoutReplacement"
|
||||
withoutReplacement n pop
|
||||
| n >= length pop = return pop
|
||||
| otherwise = fmap (NE.fromList) (shuffleNofM n (length pop) (NE.toList pop))
|
||||
|
|
|
|||
|
|
@ -17,40 +17,6 @@ instance ToRecord IrisClass
|
|||
|
||||
irisTrainingData :: [((Float, Float, Float, Float), IrisClass)]
|
||||
irisTrainingData =
|
||||
[ ((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)
|
||||
]
|
||||
|
||||
irisTestData :: [((Float, Float, Float, Float), IrisClass)]
|
||||
irisTestData =
|
||||
[ ((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),
|
||||
|
|
@ -170,4 +136,39 @@ irisTestData =
|
|||
((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)]
|
||||
((6.0, 2.2, 4.0, 1.0), Versicolor)
|
||||
]
|
||||
|
||||
irisTestData :: [((Float, Float, Float, Float), IrisClass)]
|
||||
irisTestData =
|
||||
[ ((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)
|
||||
]
|
||||
|
|
|
|||
177
src/IrisData.hs.template
Normal file
177
src/IrisData.hs.template
Normal file
|
|
@ -0,0 +1,177 @@
|
|||
{-# 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 =
|
||||
[
|
||||
|
||||
]
|
||||
|
|
@ -12,21 +12,19 @@ module IrisDataset
|
|||
)
|
||||
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 Protolude.Error
|
||||
import qualified Type.Reflection as Ref
|
||||
|
||||
irisLE :: LambdaEnviroment
|
||||
|
|
@ -37,9 +35,9 @@ irisLE =
|
|||
[ ((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 -> Float -> Float -> Float))), ["if'","if'","if'","if'","if'","if'","if'","if'"]),
|
||||
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Bool -> Bool))), ["(&&)", "(||)"]),
|
||||
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> IrisClass -> IrisClass -> IrisClass))), ["if'"])
|
||||
((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> IrisClass -> IrisClass -> IrisClass))), ["if'","if'","if'","if'","if'","if'","if'","if'","if'","if'"])
|
||||
],
|
||||
constants =
|
||||
Map.fromList
|
||||
|
|
@ -53,9 +51,9 @@ irisLE =
|
|||
ExpressionWeights
|
||||
{ lambdaSpucker = 1,
|
||||
lambdaSchlucker = 1,
|
||||
symbol = 1,
|
||||
variable = 2,
|
||||
constant = 1
|
||||
symbol = 30,
|
||||
variable = 100,
|
||||
constant = 5
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -64,14 +62,15 @@ 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",
|
||||
training = True,
|
||||
trainingData =
|
||||
( map fst irisTrainingData,
|
||||
map snd irisTrainingData
|
||||
),
|
||||
testData =
|
||||
( map fst irisTestData,
|
||||
map snd irisTestData
|
||||
),
|
||||
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
|
||||
-- todo: kindaHacky
|
||||
results = Map.empty
|
||||
|
|
@ -80,11 +79,9 @@ irisLEE =
|
|||
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,
|
||||
training :: Bool,
|
||||
trainingData :: ([(Float, Float, Float, Float)], [IrisClass]),
|
||||
testData :: ([(Float, Float, Float, Float)], [IrisClass]),
|
||||
exTargetType :: TypeRep,
|
||||
-- todo: kindaHacky
|
||||
results :: Map TypeRequester FittnesRes
|
||||
|
|
@ -96,7 +93,6 @@ data FittnesRes = FittnesRes
|
|||
fitnessGeoMean :: R,
|
||||
fitnessMean :: R,
|
||||
accuracy :: Int,
|
||||
biasDist :: R,
|
||||
biasSize :: R
|
||||
}
|
||||
deriving (Show)
|
||||
|
|
@ -111,9 +107,11 @@ instance Evaluator TypeRequester LamdaExecutionEnv FittnesRes where
|
|||
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)
|
||||
let res = foldr insertPair (results env) (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 = mapM (evalResult ex) trs
|
||||
|
|
@ -123,11 +121,10 @@ 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 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) :: 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 biasSmall = exp ((-(fromIntegral (countTrsR tr)))/1000) -- 0 (schlecht) bis 1 (gut)
|
||||
let fitness' = meanOfAccuricyPerClass resAndTarget
|
||||
let score = fitness' + (biasSmall - 1)
|
||||
return
|
||||
|
|
@ -138,7 +135,6 @@ evalResult ex tr = do
|
|||
fitnessMean = meanOfAccuricyPerClass resAndTarget,
|
||||
fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
|
||||
accuracy = acc,
|
||||
biasDist = biasWellDistributed,
|
||||
biasSize = biasSmall
|
||||
}
|
||||
)
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@
|
|||
|
||||
module LambdaCalculus where
|
||||
|
||||
import Data.List (foldr1, last)
|
||||
import Data.List (foldr1, last, nub, intersect, (!!), (\\))
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe
|
||||
|
|
@ -20,6 +20,8 @@ import Data.Typeable
|
|||
import GA
|
||||
import Pretty
|
||||
import Protolude
|
||||
import Protolude.Error
|
||||
import Debug.Trace as DB
|
||||
import Test.QuickCheck hiding (sample, shuffle)
|
||||
import Test.QuickCheck.Monadic (assert, monadicIO)
|
||||
import qualified Type.Reflection as Ref
|
||||
|
|
@ -92,7 +94,8 @@ 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 | Constan ConVal
|
||||
-- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show)
|
||||
|
||||
|
||||
eToLambdaExpressionS :: LambdaExpression -> Text
|
||||
eToLambdaExpressionS (LambdaSpucker typeRequester1 typeRequester2 boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionS typeRequester2 <> ") " <> toLambdaExpressionS typeRequester1
|
||||
|
|
@ -240,53 +243,119 @@ instance Environment TypeRequester LambdaEnviroment where
|
|||
nX _ = 3 -- todo!
|
||||
|
||||
crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do
|
||||
return Nothing
|
||||
let trCount = countTrsR tr1
|
||||
selectedIndex1 <- uniform 1 trCount
|
||||
let (depthAt, selectedTr1@(TR _ _ bound1)) = depthLeftAndTypeAtR tr1 selectedIndex1 maxDepth
|
||||
let indexes = findIndicesWhere tr2 (isCompatibleTr selectedTr1) 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)
|
||||
)
|
||||
|
||||
-- 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
|
||||
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)"
|
||||
|
||||
-- findIndicesWhere':: [TypeRequester] -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)]
|
||||
-- findIndicesWhere' (tr:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr))
|
||||
|
||||
-- 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 -> TypeRequester -> Bool
|
||||
isCompatibleTr tr1@(TR trep1 _ bound1) tr2@(TR trep2 _ bound2) | trep1 == trep2 = allUsedBound (usedVars bound1 tr1) bound2 && allUsedBound (usedVars bound2 tr2) bound1
|
||||
| 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 -> Bool) -> Int -> [(TypeRequester, Int)]
|
||||
findIndicesWhere tr@(TR t lE _) filte indx = case lE of
|
||||
Just le -> if filte tr then (tr, indx+1):(findIndicesWhere' (asList le) filte (indx+1)) else (findIndicesWhere' (asList le) filte (indx+1))
|
||||
Nothing -> error "Nothing in findIndicesWhere"
|
||||
|
||||
findIndicesWhere':: [TypeRequester] -> (TypeRequester -> Bool) -> Int -> [(TypeRequester, Int)]
|
||||
findIndicesWhere' [] _ _ = []
|
||||
findIndicesWhere' [tr] f indx = (findIndicesWhere tr f indx)
|
||||
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 _) _ = undefined
|
||||
replaceAtR _ (TR _ Nothing _) _ = error "Nothing in replaceAtR"
|
||||
|
||||
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 _) _ = undefined
|
||||
replaceAt _ (Constan _) _ = error "Nothing in replaceAt"
|
||||
|
||||
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 _ [] _ = undefined
|
||||
replaceInSubtreeWithIndex _ [] _ = error "Index not found in replaceInSubtreeWithIndex"
|
||||
|
||||
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 = undefined
|
||||
depthLeftAndTypeAtR (TR _ Nothing _) indexLeft depthLeft = error "Nothing in depthLeftAndTypeAtR"
|
||||
|
||||
depthLeftAndTypeAt :: LambdaExpression -> Int -> Int -> (Int, TypeRequester)
|
||||
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 = undefined
|
||||
depthLeftAndTypeInSubtreeWithIndex [] indexLeft depthLeft = error "Index not found in depthLeftAndTypeInSubtreeWithIndex"
|
||||
|
||||
countTrsR :: TypeRequester -> Int
|
||||
countTrsR tr@(TR t lE _) = case lE of
|
||||
|
|
|
|||
18
src/Main.hs
18
src/Main.hs
|
|
@ -10,6 +10,8 @@ import System.IO
|
|||
-- import Szenario212Pun
|
||||
-- import Szenario191
|
||||
import IrisDataset
|
||||
import Debug.Trace as DB
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
data Options = Options
|
||||
{ iterations :: !N,
|
||||
|
|
@ -24,7 +26,7 @@ options =
|
|||
( long "iterations"
|
||||
<> short 'i'
|
||||
<> metavar "N"
|
||||
<> value 1000
|
||||
<> value 500
|
||||
<> help "Number of iterations"
|
||||
)
|
||||
<*> option
|
||||
|
|
@ -32,7 +34,7 @@ options =
|
|||
( long "population-size"
|
||||
<> short 'p'
|
||||
<> metavar "N"
|
||||
<> value 50
|
||||
<> value 100
|
||||
<> help "Population size"
|
||||
)
|
||||
|
||||
|
|
@ -52,12 +54,12 @@ main =
|
|||
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
|
||||
pop' <- runEffect (for run' logCsv)
|
||||
irisLEE' <- calc irisLEE pop'
|
||||
let (res, _) = bests irisLEE' 5 pop'
|
||||
let irisLEE' = irisLEE {training = False}
|
||||
irisLEE' <- calc irisLEE' res
|
||||
mapM_ (format irisLEE') res
|
||||
where
|
||||
format irisL s = do
|
||||
let f = fitness' irisL s
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user