Hans/haga
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

finish German

Browse Source
This commit is contained in:
Johannes Merl 2024-04-16 11:47:22 +02:00
parent 4286ee36d9
commit 8432103a18
5 changed files with 139 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
haga.cabal
View File

@ -49,9 +49,9 @@ library
, Pretty , Pretty
, Szenario191 , Szenario191
, LambdaCalculus , LambdaCalculus
, IrisDataset , GermanDataset
, IrisData , GermanData
, Utils
executable haga executable haga
build-depends: base build-depends: base
, bytestring , bytestring
@ -83,8 +83,9 @@ executable haga
, Pretty , Pretty
, Szenario191 , Szenario191
, LambdaCalculus , LambdaCalculus
, IrisDataset , GermanDataset
, IrisData , GermanData
, Utils
executable haga-test executable haga-test
build-depends: base build-depends: base
@ -118,5 +119,6 @@ executable haga-test
, Pretty , Pretty
, Szenario191 , Szenario191
, LambdaCalculus , LambdaCalculus
, IrisDataset , GermanDataset
, IrisData , GermanData
, Utils

9
src/IrisData.hs
View File

@ -136,12 +136,8 @@ irisTrainingData =
((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),
] ((5.0, 3.5, 1.6, 0.6), Setosa),
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.6, 3.1, 1.5, 0.2), Setosa),
((4.8, 3.4, 1.6, 0.2), Setosa), ((4.8, 3.4, 1.6, 0.2), Setosa),
((4.8, 3.0, 1.4, 0.3), Setosa), ((4.8, 3.0, 1.4, 0.3), Setosa),
@ -172,3 +168,4 @@ irisTestData =
((6.1, 2.6, 5.6, 1.4), Virginica), ((6.1, 2.6, 5.6, 1.4), Virginica),
((6.6, 2.9, 4.6, 1.3), Versicolor) ((6.6, 2.9, 4.6, 1.3), Versicolor)
] ]

47
src/IrisDataset.hs
View File

@ -15,6 +15,7 @@ where
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 System.Random.MWC (createSystemRandom)
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
@ -24,6 +25,7 @@ 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 Utils
import Protolude.Error import Protolude.Error
import qualified Type.Reflection as Ref import qualified Type.Reflection as Ref
@ -64,15 +66,35 @@ irisLEE =
imports = ["IrisDataset"], imports = ["IrisDataset"],
training = True, training = True,
trainingData = trainingData =
( map fst irisTrainingData, ( map fst (takeFraktion 0.8 irisTrainingData),
map snd irisTrainingData map snd (takeFraktion 0.8 irisTrainingData)
), ),
testData = testData =
( map fst irisTestData, ( map fst (dropFraktion 0.8 irisTrainingData),
map snd irisTestData map snd (dropFraktion 0.8 irisTrainingData)
),
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
results = Map.empty
}
shuffledIrisLEE :: IO LamdaExecutionEnv
shuffledIrisLEE = 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"],
training = True,
trainingData =
( map fst (takeFraktion 0.8 itD),
map snd (takeFraktion 0.8 itD)
),
testData =
( map fst (dropFraktion 0.8 itD),
map snd (dropFraktion 0.8 itD)
), ),
exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))), exTargetType = (Ref.SomeTypeRep (Ref.TypeRep @(Float -> Float -> Float -> Float -> IrisClass))),
-- todo: kindaHacky
results = Map.empty results = Map.empty
} }
@ -92,8 +114,9 @@ data FittnesRes = FittnesRes
fitnessTotal :: R, fitnessTotal :: R,
fitnessGeoMean :: R, fitnessGeoMean :: R,
fitnessMean :: R, fitnessMean :: R,
accuracy :: Int, accuracy :: R,
biasSize :: R biasSize :: R,
totalSize :: N
} }
deriving (Show) deriving (Show)
@ -104,10 +127,11 @@ instance Evaluator TypeRequester LamdaExecutionEnv FittnesRes where
fitness' env tr = (results env) Map.! tr fitness' env tr = (results env) Map.! tr
calc env pop = do calc env pop = do
let toAdd = NE.filter (\k -> not (Map.member k (results env))) pop let relevantResults = Map.filterWithKey (\k _ -> contains pop k) (results env)
let toAdd = NE.filter (\k -> not (Map.member k relevantResults)) pop
toInsert <- Hint.runInterpreter (evalResults env toAdd) 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 (error ("To insert is " <> show toInsert)) toInsert) let res = foldr insertPair relevantResults (fromRight (error ("To insert is " <> show toInsert)) toInsert)
return env {results = res} return env {results = res}
dset :: LamdaExecutionEnv -> ([(Float, Float, Float, Float)], [IrisClass]) dset :: LamdaExecutionEnv -> ([(Float, Float, Float, Float)], [IrisClass])
@ -123,7 +147,7 @@ evalResult ex tr = do
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 (dset ex)) let res = map (\(a, b, c, d) -> result a b c d) (fst (dset ex))
let resAndTarget = (zip (snd (dset 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) / fromIntegral (length resAndTarget)
let biasSmall = exp ((-(fromIntegral (countTrsR tr)))/1000) -- 0 (schlecht) bis 1 (gut) let biasSmall = exp ((-(fromIntegral (countTrsR tr)))/1000) -- 0 (schlecht) bis 1 (gut)
let fitness' = meanOfAccuricyPerClass resAndTarget let fitness' = meanOfAccuricyPerClass resAndTarget
let score = fitness' + (biasSmall - 1) let score = fitness' + (biasSmall - 1)
@ -135,7 +159,8 @@ evalResult ex tr = do
fitnessMean = meanOfAccuricyPerClass resAndTarget, fitnessMean = meanOfAccuricyPerClass resAndTarget,
fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget, fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
accuracy = acc, accuracy = acc,
biasSize = biasSmall biasSize = biasSmall,
totalSize = countTrsR tr
} }
) )

119
src/LambdaCalculus.hs
View File

@ -9,7 +9,7 @@
module LambdaCalculus where module LambdaCalculus where
import Data.List (foldr1, last, nub, intersect, (!!), (\\)) import Data.List (foldr1, intersect, last, nub, (!!), (\\))
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
@ -17,14 +17,15 @@ import Data.Random
import qualified Data.Text as T import qualified Data.Text as T
import Data.Tuple.Extra import Data.Tuple.Extra
import Data.Typeable import Data.Typeable
import Debug.Trace as DB
import GA import GA
import Pretty import Pretty
import Protolude import Protolude
import Protolude.Error 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
import Utils
data ExpressionWeights = ExpressionWeights data ExpressionWeights = ExpressionWeights
{ lambdaSpucker :: Int, { lambdaSpucker :: Int,
@ -73,7 +74,6 @@ exampleLE =
type BoundVars = [TypeRep] 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... -- 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 type ConVal = Text
@ -96,7 +96,6 @@ toLambdaExpressionS (TR _ (Nothing) _) = "Invalid Lambda Epr"
-- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show) -- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [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
eToLambdaExpressionS (LambdaSchlucker typeRequester boundVars) = "\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionS typeRequester eToLambdaExpressionS (LambdaSchlucker typeRequester boundVars) = "\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionS typeRequester
@ -179,7 +178,7 @@ genLambdaSchlucker env@(LambdaEnviroment functions constants _ _ weights) depthL
let args = typeRepArgs target let args = typeRepArgs target
let lambaType = fromJust (head args) let lambaType = fromJust (head args)
let toFind = last args let toFind = last args
typeRequester <- genTypeRequester env depthLeft toFind (boundVar ++ [lambaType]) typeRequester <- genTypeRequester env (depthLeft + 1) toFind (boundVar ++ [lambaType])
return (LambdaSchlucker typeRequester (boundVar ++ [lambaType])) return (LambdaSchlucker typeRequester (boundVar ++ [lambaType]))
genLambdaConst :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression genLambdaConst :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
@ -234,6 +233,13 @@ instance Environment TypeRequester LambdaEnviroment where
return tr return tr
mutate env@(LambdaEnviroment _ _ _ maxDepth _) tr = do mutate env@(LambdaEnviroment _ _ _ maxDepth _) tr = do
selfCrossover <- uniform True False
co <- crossover1 env tr tr
if selfCrossover && isJust co
then do
let (tr1, tr2) = fromJust co
return $ minimumBy (compare `on` countTrsR) [tr1, tr2]
else do
let trCount = countTrsR (tr) let trCount = countTrsR (tr)
selectedTR <- uniform 1 trCount selectedTR <- uniform 1 trCount
let (depthAt, (TR trep _ bound)) = depthLeftAndTypeAtR tr selectedTR maxDepth let (depthAt, (TR trep _ bound)) = depthLeftAndTypeAtR tr selectedTR maxDepth
@ -245,9 +251,13 @@ instance Environment TypeRequester LambdaEnviroment where
crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do
let trCount = countTrsR tr1 let trCount = countTrsR tr1
selectedIndex1 <- uniform 1 trCount selectedIndex1 <- uniform 1 trCount
let (depthAt, selectedTr1@(TR _ _ bound1)) = depthLeftAndTypeAtR tr1 selectedIndex1 maxDepth let (depthAt1, selectedTr1@(TR _ _ bound1)) = depthLeftAndTypeAtR tr1 selectedIndex1 maxDepth
let indexes = findIndicesWhere tr2 (isCompatibleTr selectedTr1) 0 let depthLeftNeeded = depthOfTR selectedTr1
if length indexes == 0 then return Nothing else (do let indexes = findIndicesWhere tr2 (isCompatibleTr selectedTr1 (maxDepth - depthAt1) depthLeftNeeded) 0 0
if length indexes == 0
then return Nothing
else
( do
(selectedTr2@(TR _ _ bound2), selectedIndex2) <- randomElement indexes (selectedTr2@(TR _ _ bound2), selectedIndex2) <- randomElement indexes
selectedTr2 <- adaptBoundVars selectedTr2 bound1 selectedTr2 <- adaptBoundVars selectedTr2 bound1
selectedTr1 <- adaptBoundVars selectedTr1 bound2 selectedTr1 <- adaptBoundVars selectedTr1 bound2
@ -256,8 +266,12 @@ instance Environment TypeRequester LambdaEnviroment where
return $ Just (child1, child2) return $ Just (child1, child2)
) )
-- helper -- helper
depthOfTR :: TypeRequester -> Int
depthOfTR (TR _ (Just le@(LambdaSchlucker _ _)) _) = maximum (0:(map depthOfTR (asList le)))
depthOfTR (TR _ (Just le) _) = maximum (0:(map depthOfTR (asList le))) + 1
depthOfTR _ = error "le Not Just (depthOfTR)"
adaptBoundVars :: TypeRequester -> BoundVars -> RVar TypeRequester adaptBoundVars :: TypeRequester -> BoundVars -> RVar TypeRequester
adaptBoundVars tr@(TR _ _ bvOld) bvNew = do adaptBoundVars tr@(TR _ _ bvOld) bvNew = do
newIndexMap <- generateConversionIndexMap bvOld bvNew newIndexMap <- generateConversionIndexMap bvOld bvNew
@ -267,27 +281,30 @@ convertTr:: TypeRequester -> BoundVars -> BoundVars -> Map TypeRep (Int -> Int)
convertTr tr@(TR tRp (Just le) bvCurr) bvOld bvNew mapper = TR tRp (Just (convertLe le bvOld bvNew mapper)) (bvNew ++ (bvCurr \\ bvOld)) 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)" convertTr _ _ _ _ = error "le Not Just (convertTr)"
-- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show) -- 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 :: LambdaExpression -> BoundVars -> BoundVars -> Map TypeRep (Int -> Int) -> LambdaExpression
convertLe (LambdaSpucker tr1 tr2 bvCurr) bvOld bvNew mapper = LambdaSpucker (convertTrf tr1) (convertTrf tr2) (bvNew ++ (bvCurr \\ bvOld)) convertLe (LambdaSpucker tr1 tr2 bvCurr) bvOld bvNew mapper = LambdaSpucker (convertTrf tr1) (convertTrf tr2) (bvNew ++ (bvCurr \\ bvOld))
where convertTrf tr = convertTr tr bvOld bvNew mapper where
convertTrf tr = convertTr tr bvOld bvNew mapper
convertLe (LambdaSchlucker tr bvCurr) bvOld bvNew mapper = LambdaSchlucker (convertTrf tr) (bvNew ++ (bvCurr \\ bvOld)) convertLe (LambdaSchlucker tr bvCurr) bvOld bvNew mapper = LambdaSchlucker (convertTrf tr) (bvNew ++ (bvCurr \\ bvOld))
where convertTrf tr = convertTr tr bvOld bvNew mapper where
convertTrf tr = convertTr tr bvOld bvNew mapper
convertLe (Symbol cv trs bvCurr) bvOld bvNew mapper = Symbol cv (map convertTrf trs) (bvNew ++ (bvCurr \\ bvOld)) convertLe (Symbol cv trs bvCurr) bvOld bvNew mapper = Symbol cv (map convertTrf trs) (bvNew ++ (bvCurr \\ bvOld))
where convertTrf tr = convertTr tr bvOld bvNew mapper 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)) 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 where
convertTrf tr = convertTr tr bvOld bvNew mapper
convertLe le@(Constan _) _ _ _ = le convertLe le@(Constan _) _ _ _ = le
generateConversionIndexMap :: BoundVars -> BoundVars -> RVar (Map TypeRep (Int -> Int)) generateConversionIndexMap :: BoundVars -> BoundVars -> RVar (Map TypeRep (Int -> Int))
generateConversionIndexMap bvOld bvNew = do generateConversionIndexMap bvOld bvNew = do
funcs <- mapM (\bT -> genMapper (count bvOld bT - 1) (count bvNew bT - 1)) (nub bvOld) funcs <- mapM (\bT -> genMapper (count bvOld bT - 1) (count bvNew bT - 1)) (nub bvOld)
return $ Map.fromList $ zip (nub bvOld) funcs return $ Map.fromList $ zip (nub bvOld) funcs
genMapper :: Int -> Int -> RVar (Int -> Int) genMapper :: Int -> Int -> RVar (Int -> Int)
genMapper i j | i == j = return identity genMapper i j
| i == j = return identity
| i < j = return $ \int -> if int <= i then int else int + (j - i) | i < j = return $ \int -> if int <= i then int else int + (j - i)
| i > j = do | i > j = do
permutationForUnbound <- genPermutation i j permutationForUnbound <- genPermutation i j
@ -295,39 +312,40 @@ genMapper i j | i == j = return identity
| otherwise = error "impossible case in genMapper" | otherwise = error "impossible case in genMapper"
genMapperRandomAssment :: Int -> Int -> [Int] -> Int -> Int genMapperRandomAssment :: Int -> Int -> [Int] -> Int -> Int
genMapperRandomAssment i j permutationForUnbound int | int <= j = int genMapperRandomAssment i j permutationForUnbound int
| int <= j = int
| int > i = int - (i - j) | int > i = int - (i - j)
| otherwise = permutationForUnbound !! (int - j - 1) | otherwise = permutationForUnbound !! (int - j - 1)
genPermutation :: Int -> Int -> RVar [Int] genPermutation :: Int -> Int -> RVar [Int]
genPermutation i j = replicateM (i - j) (uniform 0 j) genPermutation i j = replicateM (i - j) (uniform 0 j)
isCompatibleTr:: TypeRequester -> TypeRequester -> Bool isCompatibleTr :: TypeRequester -> Int -> Int -> TypeRequester -> Int -> Bool
isCompatibleTr tr1@(TR trep1 _ bound1) tr2@(TR trep2 _ bound2) | trep1 == trep2 = allUsedBound (usedVars bound1 tr1) bound2 && allUsedBound (usedVars bound2 tr2) bound1 isCompatibleTr tr1@(TR trep1 _ bound1) maxDepthOfTR2 maxDepthOfNode tr2@(TR trep2 _ bound2) depthOfNode
| trep1 == trep2 = allUsedBound (usedVars bound1 tr1) bound2 && allUsedBound (usedVars bound2 tr2) bound1 && maxDepthOfTR2 >= (depthOfTR tr2) && maxDepthOfNode >= depthOfNode
| otherwise = False | otherwise = False
allUsedBound :: BoundVars -> BoundVars -> Bool allUsedBound :: BoundVars -> BoundVars -> Bool
allUsedBound used available = all (\x -> any (== x) available) used allUsedBound used available = all (\x -> any (== x) available) used
usedVars :: BoundVars -> TypeRequester -> BoundVars 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 (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 boundOld tr@(TR trep1 (Just le) _) = concatMap (usedVars boundOld) (asList le)
usedVars _ _ = error "Nothing in usedVars" usedVars _ _ = error "Nothing in usedVars"
boundsConvertable :: BoundVars -> BoundVars -> Bool boundsConvertable :: BoundVars -> BoundVars -> Bool
boundsConvertable bv1 bv2 = length (nub bv2) == length (nub bv1) && length (intersect (nub bv1) bv2) == length (nub bv1) boundsConvertable bv1 bv2 = length (nub bv2) == length (nub bv1) && length (intersect (nub bv1) bv2) == length (nub bv1)
findIndicesWhere :: TypeRequester -> (TypeRequester -> Int -> Bool) -> Int -> Int -> [(TypeRequester, Int)]
findIndicesWhere:: TypeRequester -> (TypeRequester -> Bool) -> Int -> [(TypeRequester, Int)] findIndicesWhere tr@(TR _ (Just le@(LambdaSchlucker _ _)) _) filte indx currDepth = if filte tr currDepth then (tr, indx + 1) : (findIndicesWhere' (asList le) filte (indx + 1) (currDepth)) else (findIndicesWhere' (asList le) filte (indx + 1) (currDepth))
findIndicesWhere tr@(TR t lE _) filte indx = case lE of findIndicesWhere tr@(TR _ lE _) filte indx currDepth = 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)) Just le -> if filte tr currDepth then (tr, indx + 1) : (findIndicesWhere' (asList le) filte (indx + 1) (currDepth + 1)) else (findIndicesWhere' (asList le) filte (indx + 1) (currDepth + 1))
Nothing -> error "Nothing in findIndicesWhere" Nothing -> error "Nothing in findIndicesWhere"
findIndicesWhere':: [TypeRequester] -> (TypeRequester -> Bool) -> Int -> [(TypeRequester, Int)] findIndicesWhere' :: [TypeRequester] -> (TypeRequester -> Int -> Bool) -> Int -> Int -> [(TypeRequester, Int)]
findIndicesWhere' [] _ _ = [] findIndicesWhere' [] _ _ _ = []
findIndicesWhere' [tr] f indx = (findIndicesWhere tr f indx) findIndicesWhere' [tr] f indx currDepth = (findIndicesWhere tr f indx currDepth)
findIndicesWhere' (tr:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr)) findIndicesWhere' (tr : trs) f indx currDepth = (findIndicesWhere tr f indx currDepth) ++ (findIndicesWhere' trs f (indx + countTrsR tr) currDepth)
replaceAtR :: Int -> TypeRequester -> TypeRequester -> TypeRequester replaceAtR :: Int -> TypeRequester -> TypeRequester -> TypeRequester
replaceAtR 1 _ with = with replaceAtR 1 _ with = with
@ -351,6 +369,7 @@ depthLeftAndTypeAtR (TR _ (Just le) _) indexLeft depthLeft = depthLeftAndTypeAt
depthLeftAndTypeAtR (TR _ Nothing _) indexLeft depthLeft = error "Nothing in depthLeftAndTypeAtR" depthLeftAndTypeAtR (TR _ Nothing _) indexLeft depthLeft = error "Nothing in depthLeftAndTypeAtR"
depthLeftAndTypeAt :: LambdaExpression -> Int -> Int -> (Int, TypeRequester) depthLeftAndTypeAt :: LambdaExpression -> Int -> Int -> (Int, TypeRequester)
depthLeftAndTypeAt le@(LambdaSchlucker tr bv) indexLeft depthLeft = depthLeftAndTypeInSubtreeWithIndex (asList le) indexLeft (depthLeft + 1)
depthLeftAndTypeAt le indexLeft depthLeft = depthLeftAndTypeInSubtreeWithIndex (asList le) indexLeft depthLeft depthLeftAndTypeAt le indexLeft depthLeft = depthLeftAndTypeInSubtreeWithIndex (asList le) indexLeft depthLeft
depthLeftAndTypeInSubtreeWithIndex :: [TypeRequester] -> Int -> Int -> (Int, TypeRequester) depthLeftAndTypeInSubtreeWithIndex :: [TypeRequester] -> Int -> Int -> (Int, TypeRequester)
@ -365,17 +384,6 @@ countTrsR tr@(TR t lE _) = case lE of
countTrs :: LambdaExpression -> Int countTrs :: LambdaExpression -> Int
countTrs le = sum (map countTrsR (asList le)) countTrs le = sum (map countTrsR (asList le))
repeatedly :: (a -> Maybe a) -> a -> [a]
repeatedly f x = case f x of
Nothing -> []
Just y -> y : repeatedly f y
count :: (Eq a) => [a] -> a -> Int
count [] find = 0
count ys find = length xs
where
xs = [xs | xs <- ys, xs == find]
-- Test Stuff -- Test Stuff
testConstInt :: TypeRequester testConstInt :: TypeRequester
@ -535,34 +543,3 @@ eToLambdaExpressionShort (Constan (valS)) = valS
res :: Int -> ResClass res :: Int -> ResClass
res = ((\lInt0 -> ((iteClass ((eqInt ((lInt0) :: (Int)) ((1) :: (Int))) :: (Bool)) ((Class1) :: (ResClass)) ((iteClass ((eqInt ((lInt0) :: (Int)) ((2) :: (Int))) :: (Bool)) ((Class2) :: (ResClass)) ((iteClass ((eqInt ((lInt0) :: (Int)) ((3) :: (Int))) :: (Bool)) ((Class3) :: (ResClass)) ((Class3) :: (ResClass))) :: (ResClass))) :: (ResClass))) :: (ResClass))) :: (Int -> ResClass)) res = ((\lInt0 -> ((iteClass ((eqInt ((lInt0) :: (Int)) ((1) :: (Int))) :: (Bool)) ((Class1) :: (ResClass)) ((iteClass ((eqInt ((lInt0) :: (Int)) ((2) :: (Int))) :: (Bool)) ((Class2) :: (ResClass)) ((iteClass ((eqInt ((lInt0) :: (Int)) ((3) :: (Int))) :: (Bool)) ((Class3) :: (ResClass)) ((Class3) :: (ResClass))) :: (ResClass))) :: (ResClass))) :: (ResClass))) :: (Int -> ResClass))
meanOfAccuricyPerClass :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
meanOfAccuricyPerClass results = mean $ map (accuracyInClass results) [minBound .. maxBound]
geomeanOfAccuricyPerClass :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
geomeanOfAccuricyPerClass results = geomean $ map (accuracyInClass results) [minBound .. maxBound]
geomeanOfDistributionAccuracy :: (Enum r, Bounded r, Eq r) => [(r, r)] -> R
geomeanOfDistributionAccuracy results = geomean $ map (distributionAccuracyForClass results) [minBound .. maxBound]
distributionAccuracyForClass :: (Eq r) => [(r, r)] -> r -> R
distributionAccuracyForClass results clas = (1 - (min 1 (fromIntegral (abs ((length (inResClass results clas)) - (length (inClass results clas)))) / fromIntegral (length (inClass results clas))))) * 100
mean :: (Show f, Floating f) => [f] -> f
mean values = (sum values) * (1 / (fromIntegral (length values)))
geomean :: (Show f, Floating f) => [f] -> f
geomean values = (product values) ** (1 / (fromIntegral (length values)))
accuracyInClass :: (Eq r) => [(r, r)] -> r -> R
accuracyInClass results clas = ((accuracy'(inResClass results clas)) * 100) / fromIntegral (length (inClass results clas))
inClass :: (Eq r) => [(r, r)] -> r -> [(r, r)]
inClass results clas = (filter ((clas ==) . fst) results)
inResClass :: (Eq r) => [(r, r)] -> r -> [(r, r)]
inResClass results clas = (filter ((clas ==) . snd) results)
accuracy' :: (Eq r) => [(r, r)] -> R
accuracy' results = fromIntegral $ length (filter (\(target, res) -> (res == target)) results)

23
src/Main.hs
View File

@ -9,7 +9,7 @@ import Protolude hiding (for)
import System.IO import System.IO
-- import Szenario212Pun -- import Szenario212Pun
-- import Szenario191 -- import Szenario191
import IrisDataset import GermanDataset
import Debug.Trace as DB import Debug.Trace as DB
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
@ -26,7 +26,7 @@ options =
( long "iterations" ( long "iterations"
<> short 'i' <> short 'i'
<> metavar "N" <> metavar "N"
<> value 500 <> value 1000
<> help "Number of iterations" <> help "Number of iterations"
) )
<*> option <*> option
@ -51,18 +51,19 @@ main :: IO ()
main = main =
execParser optionsWithHelp >>= \opts -> do execParser optionsWithHelp >>= \opts -> do
hSetBuffering stdout NoBuffering hSetBuffering stdout NoBuffering
let env = irisLE germanLEE <- shuffledGermanLEE
let env = germanLE
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 germanLEE env selType 80 (5 / 100) (populationSize opts) (steps (iterations opts))
pop' <- runEffect (for run' logCsv) pop' <- runEffect (for run' logCsv)
irisLEE' <- calc irisLEE pop' germanLEE' <- calc germanLEE pop'
let (res, _) = bests irisLEE' 5 pop' let (res, _) = bests germanLEE' 5 pop'
let irisLEE' = irisLEE {training = False} let germanLEE' = germanLEE {training = False}
irisLEE' <- calc irisLEE' res germanLEE' <- calc germanLEE' res
mapM_ (format irisLEE') res mapM_ (format germanLEE') res
where where
format irisL s = do format germanL s = do
let f = fitness' irisL s let f = fitness' germanL s
putErrText $ show f <> "\n" <> pretty s putErrText $ show f <> "\n" <> pretty s
logCsv = putText . csv logCsv = putText . csv
csv (t, f) = show t <> " " <> show f csv (t, f) = show t <> " " <> show f