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
, Szenario191
, LambdaCalculus
, IrisDataset
, IrisData
, GermanDataset
, GermanData
, Utils
executable haga
build-depends: base
, bytestring
@ -83,8 +83,9 @@ executable haga
, Pretty
, Szenario191
, LambdaCalculus
, IrisDataset
, IrisData
, GermanDataset
, GermanData
, Utils
executable haga-test
build-depends: base
@ -118,5 +119,6 @@ executable haga-test
, Pretty
, Szenario191
, LambdaCalculus
, IrisDataset
, IrisData
, GermanDataset
, GermanData
, Utils

9
src/IrisData.hs
View File

@ -136,12 +136,8 @@ irisTrainingData =
((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 =
[ ((5.0, 3.5, 1.6, 0.6), Setosa),
((6.0, 2.2, 4.0, 1.0), Versicolor),
((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),
@ -172,3 +168,4 @@ irisTestData =
((6.1, 2.6, 5.6, 1.4), Virginica),
((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.Map.Strict as Map
import Data.Random
import System.Random.MWC (createSystemRandom)
import Data.Random.Distribution.Uniform
import qualified Data.Text as T
import Data.Tuple.Extra
@ -24,6 +25,7 @@ import IrisData
import qualified Language.Haskell.Interpreter as Hint
import qualified Language.Haskell.Interpreter.Unsafe as Hint
import Protolude
import Utils
import Protolude.Error
import qualified Type.Reflection as Ref
@ -64,15 +66,35 @@ irisLEE =
imports = ["IrisDataset"],
training = True,
trainingData =
( map fst irisTrainingData,
map snd irisTrainingData
( map fst (takeFraktion 0.8 irisTrainingData),
map snd (takeFraktion 0.8 irisTrainingData)
),
testData =
( map fst irisTestData,
map snd irisTestData
( map fst (dropFraktion 0.8 irisTrainingData),
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))),
-- todo: kindaHacky
results = Map.empty
}
@ -92,8 +114,9 @@ data FittnesRes = FittnesRes
fitnessTotal :: R,
fitnessGeoMean :: R,
fitnessMean :: R,
accuracy :: Int,
biasSize :: R
accuracy :: R,
biasSize :: R,
totalSize :: N
}
deriving (Show)
@ -104,10 +127,11 @@ instance Evaluator TypeRequester LamdaExecutionEnv FittnesRes where
fitness' env tr = (results env) Map.! tr
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)
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}
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)
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 acc = (foldr (\ts s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 resAndTarget) / fromIntegral (length resAndTarget)
let biasSmall = exp ((-(fromIntegral (countTrsR tr)))/1000) -- 0 (schlecht) bis 1 (gut)
let fitness' = meanOfAccuricyPerClass resAndTarget
let score = fitness' + (biasSmall - 1)
@ -135,7 +159,8 @@ evalResult ex tr = do
fitnessMean = meanOfAccuricyPerClass resAndTarget,
fitnessGeoMean = geomeanOfDistributionAccuracy resAndTarget,
accuracy = acc,
biasSize = biasSmall
biasSize = biasSmall,
totalSize = countTrsR tr
}
)

119
src/LambdaCalculus.hs
View File

@ -9,7 +9,7 @@
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.Map.Strict as Map
import Data.Maybe
@ -17,14 +17,15 @@ import Data.Random
import qualified Data.Text as T
import Data.Tuple.Extra
import Data.Typeable
import Debug.Trace as DB
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
import Utils
data ExpressionWeights = ExpressionWeights
{ lambdaSpucker :: Int,
@ -73,7 +74,6 @@ exampleLE =
type BoundVars = [TypeRep]
-- we need a dynamic typ with a concept of equality here, should we want to interpret the result, instead of compiling it...
type ConVal = Text
@ -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)
eToLambdaExpressionS :: LambdaExpression -> Text
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
@ -179,7 +178,7 @@ genLambdaSchlucker env@(LambdaEnviroment functions constants _ _ weights) depthL
let args = typeRepArgs target
let lambaType = fromJust (head 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]))
genLambdaConst :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression
@ -234,6 +233,13 @@ instance Environment TypeRequester LambdaEnviroment where
return tr
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)
selectedTR <- uniform 1 trCount
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
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
let (depthAt1, selectedTr1@(TR _ _ bound1)) = depthLeftAndTypeAtR tr1 selectedIndex1 maxDepth
let depthLeftNeeded = depthOfTR selectedTr1
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 <- adaptBoundVars selectedTr2 bound1
selectedTr1 <- adaptBoundVars selectedTr1 bound2
@ -256,8 +266,12 @@ instance Environment TypeRequester LambdaEnviroment where
return $ Just (child1, child2)
)
-- 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 tr@(TR _ _ bvOld) bvNew = do
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 _ _ _ _ = 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)
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
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
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
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
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
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
@ -295,39 +312,40 @@ genMapper i j | i == j = return identity
| otherwise = error "impossible case in genMapper"
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)
| 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
isCompatibleTr :: TypeRequester -> Int -> Int -> TypeRequester -> Int -> Bool
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
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))
findIndicesWhere :: TypeRequester -> (TypeRequester -> Int -> Bool) -> Int -> 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 _ lE _) filte indx currDepth = case lE of
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"
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))
findIndicesWhere' :: [TypeRequester] -> (TypeRequester -> Int -> Bool) -> Int -> Int -> [(TypeRequester, Int)]
findIndicesWhere' [] _ _ _ = []
findIndicesWhere' [tr] f indx currDepth = (findIndicesWhere tr f indx currDepth)
findIndicesWhere' (tr : trs) f indx currDepth = (findIndicesWhere tr f indx currDepth) ++ (findIndicesWhere' trs f (indx + countTrsR tr) currDepth)
replaceAtR :: Int -> TypeRequester -> TypeRequester -> TypeRequester
replaceAtR 1 _ with = with
@ -351,6 +369,7 @@ depthLeftAndTypeAtR (TR _ (Just le) _) indexLeft depthLeft = depthLeftAndTypeAt
depthLeftAndTypeAtR (TR _ Nothing _) indexLeft depthLeft = error "Nothing in depthLeftAndTypeAtR"
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
depthLeftAndTypeInSubtreeWithIndex :: [TypeRequester] -> Int -> Int -> (Int, TypeRequester)
@ -365,17 +384,6 @@ countTrsR tr@(TR t lE _) = case lE of
countTrs :: LambdaExpression -> Int
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
testConstInt :: TypeRequester
@ -535,34 +543,3 @@ eToLambdaExpressionShort (Constan (valS)) = valS
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))
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 Szenario212Pun
-- import Szenario191
import IrisDataset
import GermanDataset
import Debug.Trace as DB
import qualified Data.Map.Strict as Map
@ -26,7 +26,7 @@ options =
( long "iterations"
<> short 'i'
<> metavar "N"
<> value 500
<> value 1000
<> help "Number of iterations"
)
<*> option
@ -51,18 +51,19 @@ main :: IO ()
main =
execParser optionsWithHelp >>= \opts -> do
hSetBuffering stdout NoBuffering
let env = irisLE
germanLEE <- shuffledGermanLEE
let env = germanLE
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)
irisLEE' <- calc irisLEE pop'
let (res, _) = bests irisLEE' 5 pop'
let irisLEE' = irisLEE {training = False}
irisLEE' <- calc irisLEE' res
mapM_ (format irisLEE') res
germanLEE' <- calc germanLEE pop'
let (res, _) = bests germanLEE' 5 pop'
let germanLEE' = germanLEE {training = False}
germanLEE' <- calc germanLEE' res
mapM_ (format germanLEE') res
where
format irisL s = do
let f = fitness' irisL s
format germanL s = do
let f = fitness' germanL s
putErrText $ show f <> "\n" <> pretty s
logCsv = putText . csv
csv (t, f) = show t <> " " <> show f