Compare commits
2 Commits
4d40050f1a
...
4286ee36d9
Author | SHA1 | Date | |
---|---|---|---|
|
4286ee36d9 | ||
|
f891229937 |
|
@ -31,6 +31,7 @@ import Data.Random
|
||||||
import Pipes
|
import Pipes
|
||||||
import Pretty
|
import Pretty
|
||||||
import Protolude
|
import Protolude
|
||||||
|
import Protolude.Error
|
||||||
import System.Random.MWC (create, createSystemRandom)
|
import System.Random.MWC (create, createSystemRandom)
|
||||||
import Test.QuickCheck hiding (sample, shuffle)
|
import Test.QuickCheck hiding (sample, shuffle)
|
||||||
import Test.QuickCheck.Instances ()
|
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.
|
-- Generates a random population of the given size.
|
||||||
population :: e -> N -> RVar (Population i)
|
population :: e -> N -> RVar (Population i)
|
||||||
population env n
|
population env n
|
||||||
| n <= 0 = undefined
|
| n <= 0 = error "nonPositive in population"
|
||||||
| otherwise = NE.fromList <$> replicateM n (new env)
|
| otherwise = NE.fromList <$> replicateM n (new env)
|
||||||
|
|
||||||
mutate :: e -> i -> RVar i
|
mutate :: e -> i -> RVar i
|
||||||
|
@ -266,7 +267,7 @@ tournament1 ::
|
||||||
RVar i
|
RVar i
|
||||||
tournament1 eval nTrnmnt pop
|
tournament1 eval nTrnmnt pop
|
||||||
-- TODO Use Positive for this constraint
|
-- TODO Use Positive for this constraint
|
||||||
| nTrnmnt <= 0 = undefined
|
| nTrnmnt <= 0 = error "nonPositive in tournament1"
|
||||||
| otherwise = do
|
| otherwise = do
|
||||||
paricipants <- withoutReplacement nTrnmnt pop
|
paricipants <- withoutReplacement nTrnmnt pop
|
||||||
return $ NE.head $ fst $ bests eval 1 paricipants
|
return $ NE.head $ fst $ bests eval 1 paricipants
|
||||||
|
@ -279,7 +280,7 @@ withoutReplacement ::
|
||||||
N ->
|
N ->
|
||||||
Population i ->
|
Population i ->
|
||||||
RVar (NonEmpty i)
|
RVar (NonEmpty i)
|
||||||
withoutReplacement 0 _ = undefined
|
withoutReplacement 0 _ = error "0 in withoutReplacement"
|
||||||
withoutReplacement n pop
|
withoutReplacement n pop
|
||||||
| n >= length pop = return pop
|
| n >= length pop = return pop
|
||||||
| otherwise = fmap (NE.fromList) (shuffleNofM n (length pop) (NE.toList 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 :: [((Float, Float, Float, Float), IrisClass)]
|
||||||
irisTrainingData =
|
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),
|
[ ((6.7, 3.1, 4.4, 1.4), Versicolor),
|
||||||
((5.4, 3.7, 1.5, 0.2), Setosa),
|
((5.4, 3.7, 1.5, 0.2), Setosa),
|
||||||
((5.4, 3.0, 4.5, 1.5), Versicolor),
|
((5.4, 3.0, 4.5, 1.5), Versicolor),
|
||||||
|
@ -170,4 +136,39 @@ irisTestData =
|
||||||
((5.7, 2.5, 5.0, 2.0), Virginica),
|
((5.7, 2.5, 5.0, 2.0), Virginica),
|
||||||
((6.8, 2.8, 4.8, 1.4), Versicolor),
|
((6.8, 2.8, 4.8, 1.4), Versicolor),
|
||||||
((6.3, 2.9, 5.6, 1.8), Virginica),
|
((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
|
where
|
||||||
|
|
||||||
import qualified Data.ByteString.Lazy as B
|
|
||||||
import Data.Csv
|
|
||||||
import qualified Data.List.NonEmpty as NE
|
import qualified Data.List.NonEmpty as NE
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
import Data.Random
|
import Data.Random
|
||||||
import Data.Random.Distribution.Uniform
|
import Data.Random.Distribution.Uniform
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.Tuple.Extra
|
import Data.Tuple.Extra
|
||||||
import qualified Debug.Trace as DB
|
|
||||||
import GA
|
import GA
|
||||||
import LambdaCalculus
|
import LambdaCalculus
|
||||||
import IrisData
|
import IrisData
|
||||||
import qualified Language.Haskell.Interpreter as Hint
|
import qualified Language.Haskell.Interpreter as Hint
|
||||||
import qualified Language.Haskell.Interpreter.Unsafe as Hint
|
import qualified Language.Haskell.Interpreter.Unsafe as Hint
|
||||||
import Protolude
|
import Protolude
|
||||||
|
import Protolude.Error
|
||||||
import qualified Type.Reflection as Ref
|
import qualified Type.Reflection as Ref
|
||||||
|
|
||||||
irisLE :: LambdaEnviroment
|
irisLE :: LambdaEnviroment
|
||||||
|
@ -37,9 +35,9 @@ irisLE =
|
||||||
[ ((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float))), ["(+)", "(-)", "(*)"]),
|
[ ((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float))), ["(+)", "(-)", "(*)"]),
|
||||||
((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Bool))), ["(>)", "(==)", "(>=)"]),
|
((Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Bool))), ["(>)", "(==)", "(>=)"]),
|
||||||
((Ref.SomeTypeRep (Ref.TypeRep @(IrisClass -> IrisClass -> 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 -> 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 =
|
constants =
|
||||||
Map.fromList
|
Map.fromList
|
||||||
|
@ -53,9 +51,9 @@ irisLE =
|
||||||
ExpressionWeights
|
ExpressionWeights
|
||||||
{ lambdaSpucker = 1,
|
{ lambdaSpucker = 1,
|
||||||
lambdaSchlucker = 1,
|
lambdaSchlucker = 1,
|
||||||
symbol = 1,
|
symbol = 30,
|
||||||
variable = 2,
|
variable = 100,
|
||||||
constant = 1
|
constant = 5
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -64,14 +62,15 @@ irisLEE =
|
||||||
LamdaExecutionEnv
|
LamdaExecutionEnv
|
||||||
{ -- For now these need to define all available functions and types. Generic functions can be used.
|
{ -- For now these need to define all available functions and types. Generic functions can be used.
|
||||||
imports = ["IrisDataset"],
|
imports = ["IrisDataset"],
|
||||||
-- Path to a CSV file containing the training dataset
|
training = True,
|
||||||
trainingDataset = "./iris.csv",
|
|
||||||
-- Path to a CSV file containing the dataset results
|
|
||||||
trainingDatasetRes = "./res.csv",
|
|
||||||
trainingData =
|
trainingData =
|
||||||
( map fst irisTrainingData,
|
( map fst irisTrainingData,
|
||||||
map snd irisTrainingData
|
map snd irisTrainingData
|
||||||
),
|
),
|
||||||
|
testData =
|
||||||
|
( map fst irisTestData,
|
||||||
|
map snd irisTestData
|
||||||
|
),
|
||||||
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
|
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
|
||||||
-- todo: kindaHacky
|
-- todo: kindaHacky
|
||||||
results = Map.empty
|
results = Map.empty
|
||||||
|
@ -80,11 +79,9 @@ irisLEE =
|
||||||
data LamdaExecutionEnv = LamdaExecutionEnv
|
data LamdaExecutionEnv = LamdaExecutionEnv
|
||||||
{ -- For now these need to define all available functions and types. Generic functions can be used.
|
{ -- For now these need to define all available functions and types. Generic functions can be used.
|
||||||
imports :: [Text],
|
imports :: [Text],
|
||||||
-- Path to a CSV file containing the training dataset
|
training :: Bool,
|
||||||
trainingDataset :: FilePath,
|
|
||||||
-- Path to a CSV file containing the dataset results
|
|
||||||
trainingDatasetRes :: FilePath,
|
|
||||||
trainingData :: ([(Float, Float, Float, Float)], [IrisClass]),
|
trainingData :: ([(Float, Float, Float, Float)], [IrisClass]),
|
||||||
|
testData :: ([(Float, Float, Float, Float)], [IrisClass]),
|
||||||
exTargetType :: TypeRep,
|
exTargetType :: TypeRep,
|
||||||
-- todo: kindaHacky
|
-- todo: kindaHacky
|
||||||
results :: Map TypeRequester FittnesRes
|
results :: Map TypeRequester FittnesRes
|
||||||
|
@ -96,7 +93,6 @@ data FittnesRes = FittnesRes
|
||||||
fitnessGeoMean :: R,
|
fitnessGeoMean :: R,
|
||||||
fitnessMean :: R,
|
fitnessMean :: R,
|
||||||
accuracy :: Int,
|
accuracy :: Int,
|
||||||
biasDist :: R,
|
|
||||||
biasSize :: R
|
biasSize :: R
|
||||||
}
|
}
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
@ -111,9 +107,11 @@ instance Evaluator TypeRequester LamdaExecutionEnv FittnesRes where
|
||||||
let toAdd = NE.filter (\k -> not (Map.member k (results env))) pop
|
let toAdd = NE.filter (\k -> not (Map.member k (results env))) pop
|
||||||
toInsert <- Hint.runInterpreter (evalResults env toAdd)
|
toInsert <- Hint.runInterpreter (evalResults env toAdd)
|
||||||
let insertPair (key, val) m = Map.insert key val m
|
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}
|
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 :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, FittnesRes)]
|
||||||
evalResults ex trs = mapM (evalResult ex) trs
|
evalResults ex trs = mapM (evalResult ex) trs
|
||||||
|
@ -123,11 +121,10 @@ evalResult ex tr = do
|
||||||
Hint.setImports $ (map T.unpack (imports ex)) ++ ["Protolude"]
|
Hint.setImports $ (map T.unpack (imports ex)) ++ ["Protolude"]
|
||||||
Hint.unsafeSetGhcOption "-O2"
|
Hint.unsafeSetGhcOption "-O2"
|
||||||
result <- Hint.interpret (T.unpack (toLambdaExpressionS tr)) (Hint.as :: Float -> Float -> Float -> Float -> IrisClass)
|
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 res = map (\(a, b, c, d) -> result a b c d) (fst (dset ex))
|
||||||
let resAndTarget = (zip (snd (trainingData ex)) res)
|
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 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)))/1000) -- 0 (schlecht) bis 1 (gut)
|
||||||
let biasSmall = exp (-(fromIntegral (countTrsR tr))) -- 0 (schlecht) bis 1 (gut)
|
|
||||||
let fitness' = meanOfAccuricyPerClass resAndTarget
|
let fitness' = meanOfAccuricyPerClass resAndTarget
|
||||||
let score = fitness' + (biasSmall - 1)
|
let score = fitness' + (biasSmall - 1)
|
||||||
return
|
return
|
||||||
|
@ -138,7 +135,6 @@ evalResult ex tr = do
|
||||||
fitnessMean = meanOfAccuricyPerClass resAndTarget,
|
fitnessMean = meanOfAccuricyPerClass resAndTarget,
|
||||||
fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
|
fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
|
||||||
accuracy = acc,
|
accuracy = acc,
|
||||||
biasDist = biasWellDistributed,
|
|
||||||
biasSize = biasSmall
|
biasSize = biasSmall
|
||||||
}
|
}
|
||||||
)
|
)
|
||||||
|
|
|
@ -9,7 +9,7 @@
|
||||||
|
|
||||||
module LambdaCalculus where
|
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.List.NonEmpty as NE
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
@ -20,6 +20,8 @@ import Data.Typeable
|
||||||
import GA
|
import GA
|
||||||
import Pretty
|
import Pretty
|
||||||
import Protolude
|
import Protolude
|
||||||
|
import Protolude.Error
|
||||||
|
import Debug.Trace as DB
|
||||||
import Test.QuickCheck hiding (sample, shuffle)
|
import Test.QuickCheck hiding (sample, shuffle)
|
||||||
import Test.QuickCheck.Monadic (assert, monadicIO)
|
import Test.QuickCheck.Monadic (assert, monadicIO)
|
||||||
import qualified Type.Reflection as Ref
|
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 typeRep (Just lambdaExpression) boundVars) = "((" <> eToLambdaExpressionS lambdaExpression <> ") :: (" <> show typeRep <> "))"
|
||||||
toLambdaExpressionS (TR _ (Nothing) _) = "Invalid Lambda Epr"
|
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 :: LambdaExpression -> Text
|
||||||
eToLambdaExpressionS (LambdaSpucker typeRequester1 typeRequester2 boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionS typeRequester2 <> ") " <> toLambdaExpressionS typeRequester1
|
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!
|
nX _ = 3 -- todo!
|
||||||
|
|
||||||
crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do
|
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
|
-- 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)]
|
convertTr:: TypeRequester -> BoundVars -> BoundVars -> Map TypeRep (Int -> Int) -> TypeRequester
|
||||||
-- findIndicesWhere tr@(TR t lE _) filte indx = case lE of
|
convertTr tr@(TR tRp (Just le) bvCurr) bvOld bvNew mapper = TR tRp (Just (convertLe le bvOld bvNew mapper)) (bvNew ++ (bvCurr \\ bvOld))
|
||||||
-- Just le -> (tr, indx+1):(findIndicesWhere' (asList le) filte (indx+1))
|
convertTr _ _ _ _ = error "le Not Just (convertTr)"
|
||||||
-- Nothing -> undefined
|
|
||||||
|
|
||||||
-- 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 :: Int -> TypeRequester -> TypeRequester -> TypeRequester
|
||||||
replaceAtR 1 _ with = with
|
replaceAtR 1 _ with = with
|
||||||
replaceAtR i (TR tm (Just le) bV) with = TR tm (Just (replaceAt (i - 1) le with)) bV
|
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 :: 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 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 (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@(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 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 :: 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 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 :: TypeRequester -> Int -> Int -> (Int, TypeRequester)
|
||||||
depthLeftAndTypeAtR t 1 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 _ (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 :: LambdaExpression -> Int -> Int -> (Int, TypeRequester)
|
||||||
depthLeftAndTypeAt le indexLeft depthLeft = depthLeftAndTypeInSubtreeWithIndex (asList le) indexLeft depthLeft
|
depthLeftAndTypeAt le indexLeft depthLeft = depthLeftAndTypeInSubtreeWithIndex (asList le) indexLeft depthLeft
|
||||||
|
|
||||||
depthLeftAndTypeInSubtreeWithIndex :: [TypeRequester] -> Int -> Int -> (Int, TypeRequester)
|
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 (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 :: TypeRequester -> Int
|
||||||
countTrsR tr@(TR t lE _) = case lE of
|
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 Szenario212Pun
|
||||||
-- import Szenario191
|
-- import Szenario191
|
||||||
import IrisDataset
|
import IrisDataset
|
||||||
|
import Debug.Trace as DB
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
|
||||||
data Options = Options
|
data Options = Options
|
||||||
{ iterations :: !N,
|
{ iterations :: !N,
|
||||||
|
@ -24,7 +26,7 @@ options =
|
||||||
( long "iterations"
|
( long "iterations"
|
||||||
<> short 'i'
|
<> short 'i'
|
||||||
<> metavar "N"
|
<> metavar "N"
|
||||||
<> value 1000
|
<> value 500
|
||||||
<> help "Number of iterations"
|
<> help "Number of iterations"
|
||||||
)
|
)
|
||||||
<*> option
|
<*> option
|
||||||
|
@ -32,7 +34,7 @@ options =
|
||||||
( long "population-size"
|
( long "population-size"
|
||||||
<> short 'p'
|
<> short 'p'
|
||||||
<> metavar "N"
|
<> metavar "N"
|
||||||
<> value 50
|
<> value 100
|
||||||
<> help "Population size"
|
<> help "Population size"
|
||||||
)
|
)
|
||||||
|
|
||||||
|
@ -52,12 +54,12 @@ main =
|
||||||
let env = irisLE
|
let env = irisLE
|
||||||
let selType = Tournament 3
|
let selType = Tournament 3
|
||||||
let run' = run irisLEE env selType 40 (5 / 100) (populationSize opts) (steps (iterations opts))
|
let run' = run irisLEE env selType 40 (5 / 100) (populationSize opts) (steps (iterations opts))
|
||||||
pop' <-
|
pop' <- runEffect (for run' logCsv)
|
||||||
runEffect (for run' logCsv)
|
irisLEE' <- calc irisLEE pop'
|
||||||
|
let (res, _) = bests irisLEE' 5 pop'
|
||||||
irisLE <- calc irisLEE pop'
|
let irisLEE' = irisLEE {training = False}
|
||||||
let (res, _) = bests irisLE 5 pop'
|
irisLEE' <- calc irisLEE' res
|
||||||
mapM_ (format irisLE) res
|
mapM_ (format irisLEE') res
|
||||||
where
|
where
|
||||||
format irisL s = do
|
format irisL s = do
|
||||||
let f = fitness' irisL s
|
let f = fitness' irisL s
|
||||||
|
|
Loading…
Reference in New Issue
Block a user