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

cleanup

Browse Source
This commit is contained in:
Johannes Merl 2024-02-27 18:53:43 +01:00
parent 233bc40a51
commit 57cf1452bf
5 changed files with 46 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
haga.cabal
View File

@ -42,13 +42,14 @@ library
, text , text
, wl-pprint-text , wl-pprint-text
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
hs-source-dirs: src hs-source-dirs: src
exposed-modules: GA exposed-modules: GA
, Seminar , Seminar
, Pretty , Pretty
, Szenario191 , Szenario191
, LambdaCalculus , LambdaCalculus
, IrisDataset
executable haga executable haga
build-depends: base build-depends: base
@ -73,7 +74,7 @@ executable haga
, text , text
, wl-pprint-text , wl-pprint-text
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
hs-source-dirs: src hs-source-dirs: src
main-is: Main.hs main-is: Main.hs
other-modules: GA other-modules: GA
@ -81,6 +82,7 @@ executable haga
, Pretty , Pretty
, Szenario191 , Szenario191
, LambdaCalculus , LambdaCalculus
, IrisDataset
executable haga-test executable haga-test
build-depends: base build-depends: base
@ -106,7 +108,7 @@ executable haga-test
, text , text
, wl-pprint-text , wl-pprint-text
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts -O2
hs-source-dirs: src hs-source-dirs: src
main-is: Test.hs main-is: Test.hs
other-modules: GA other-modules: GA
@ -114,3 +116,4 @@ executable haga-test
, Pretty , Pretty
, Szenario191 , Szenario191
, LambdaCalculus , LambdaCalculus
, IrisDataset

4
src/GA.hs
View File

@ -31,7 +31,7 @@ import Data.Random
import Pipes import Pipes
import Pretty import Pretty
import Protolude import Protolude
import System.Random.MWC (create) 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 ()
import Test.QuickCheck.Monadic import Test.QuickCheck.Monadic
@ -211,7 +211,7 @@ run ::
Termination i -> Termination i ->
Producer (Int, R) IO (Population i) Producer (Int, R) IO (Population i)
run eval env selectionType nParents pElite nPop term = do run eval env selectionType nParents pElite nPop term = do
mwc <- liftIO create mwc <- liftIO createSystemRandom
let smpl = ((sampleFrom mwc) :: RVar a -> IO a) let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
firstPop <- liftIO $ smpl $ (population env nPop) firstPop <- liftIO $ smpl $ (population env nPop)
_ <- liftIO $ putText $ pretty $ NE.head firstPop _ <- liftIO $ putText $ pretty $ NE.head firstPop

113
src/LambdaCalculus.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@ -5,23 +6,16 @@
{-# LANGUAGE Trustworthy #-} {-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveGeneric #-}
module LambdaCalculus where module LambdaCalculus where
import Data.Dynamic import Data.List (foldr1, last)
import Data.List (foldr1, last, lookup, zipWith3, (!!), (\\))
import Data.List.Extra (delete, nubOrd, nubOrdOn)
import Data.Tuple.Extra
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
import Data.Random import Data.Random
import qualified Data.ByteString.Lazy as B
import Data.Csv
import Data.Proxy
import qualified Data.Text as T import qualified Data.Text as T
import Data.Tuple.Extra
import Data.Typeable import Data.Typeable
import GA import GA
import Pretty import Pretty
@ -29,7 +23,6 @@ import Protolude
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 qualified Language.Haskell.Interpreter as Hint
data ExpressionWeights = ExpressionWeights data ExpressionWeights = ExpressionWeights
{ lambdaSpucker :: Int, { lambdaSpucker :: Int,
@ -47,19 +40,7 @@ data LambdaEnviroment = LambdaEnviroment
weights :: ExpressionWeights weights :: ExpressionWeights
} }
data LamdaExecutionEnv = LamdaExecutionEnv { showSanifid :: (Show a) => a -> Text
-- 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,
exTargetType :: TypeRep,
-- todo: kindaHacky
results :: Map TypeRequester R
}
showSanifid:: Show a => a -> Text
showSanifid var = T.replace " -> " "To" (show var) showSanifid var = T.replace " -> " "To" (show var)
exampleLE :: LambdaEnviroment exampleLE :: LambdaEnviroment
@ -104,8 +85,6 @@ asList (Symbol _ trs _) = trs
asList (Var _ _ trs _) = trs asList (Var _ _ trs _) = trs
asList (Constan _) = [] asList (Constan _) = []
data TypeRequester = TR TypeRep (Maybe LambdaExpression) BoundVars deriving (Eq, Ord) data TypeRequester = TR TypeRep (Maybe LambdaExpression) BoundVars deriving (Eq, Ord)
toLambdaExpressionS :: TypeRequester -> Text toLambdaExpressionS :: TypeRequester -> Text
@ -229,7 +208,7 @@ genLambdaVar env@(LambdaEnviroment functions constants _ _ weights) depthLeft ta
let availTypes = filter (doTypesMatch target) boundVar let availTypes = filter (doTypesMatch target) boundVar
choosenType <- randomElement $ availTypes choosenType <- randomElement $ availTypes
let tCount = count boundVar choosenType let tCount = count boundVar choosenType
indexV <- uniform 0 (tCount-1) indexV <- uniform 0 (tCount - 1)
ret <- genLambdaVar' choosenType choosenType indexV [] env depthLeft target boundVar ret <- genLambdaVar' choosenType choosenType indexV [] env depthLeft target boundVar
return ret return ret
@ -251,27 +230,18 @@ instance Environment TypeRequester LambdaEnviroment where
return tr return tr
mutate env@(LambdaEnviroment _ _ _ maxDepth _) tr = do mutate env@(LambdaEnviroment _ _ _ maxDepth _) tr = 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
res <- genTypeRequester env depthAt trep bound res <- genTypeRequester env depthAt trep bound
return $ replaceAtR selectedTR tr res return $ replaceAtR selectedTR tr res
nX _ = 3 --todo! nX _ = 3 -- todo!
crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do
return Nothing return Nothing
instance Evaluator TypeRequester LamdaExecutionEnv where -- TODO: crossover!
fitness env tr = (results env) Map.! tr
calc env pop = do
let toAdd = NE.filter (\k -> Map.member k (results env) ) pop
let insertPair (key, val) m = Map.insert key val m
toInsert <- Hint.runInterpreter (evalResults env toAdd)
let res = foldr insertPair (results env) (fromRight undefined toInsert)
return env {results = res}
-- let trCount = countTrsR tr1 -- let trCount = countTrsR tr1
-- selectedIndex1 <- uniform 1 trCount -- selectedIndex1 <- uniform 1 trCount
-- let (depthAt, selectedTr1@(TR trep _ bound)) = depthLeftAndTypeAtR tr selectedTR maxDepth -- let (depthAt, selectedTr1@(TR trep _ bound)) = depthLeftAndTypeAtR tr selectedTR maxDepth
@ -279,79 +249,50 @@ instance Evaluator TypeRequester LamdaExecutionEnv where
-- if length indexes == 0 then return Nothing else (do -- if length indexes == 0 then return Nothing else (do
-- (selectedTr2,selectedIndex2) <- randomElement indexes) -- (selectedTr2,selectedIndex2) <- randomElement indexes)
evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, R)]
evalResults ex trs = mapM (evalResult ex) trs
data IrisClass = Setosa | Virginica | Versicolor deriving (Eq, Generic, Show)
instance FromRecord IrisClass
instance ToRecord IrisClass
evalResult :: LamdaExecutionEnv -> TypeRequester -> Hint.InterpreterT IO (TypeRequester, R)
evalResult ex tr = do
Hint.loadModules (map show (imports ex))
result <- Hint.interpret (show (toLambdaExpressionS tr)) (Hint.as ::R -> R -> R -> IrisClass)
csv <- liftIO $ B.readFile (trainingDataset ex)
let recs = (toList $ fromRight undefined $ decode NoHeader csv) :: [(R,R,R)]
let res = map ((uncurry3 result)) recs
csvRes <- liftIO $ B.readFile (trainingDatasetRes ex)
let recsRes = (toList $ fromRight undefined $ decode NoHeader csvRes) :: [IrisClass]
let score = (foldr (\ts s -> if (fst ts) == (snd ts) then s + 1 else s - 1) 0 (zip recsRes res)) :: R
return (tr, score)
-- helper -- helper
--findIndicesWhere:: TypeRequester -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)]
--findIndicesWhere tr@(TR t lE _) filte indx = case lE of -- 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)) -- Just le -> (tr, indx+1):(findIndicesWhere' (asList le) filte (indx+1))
-- Nothing -> undefined -- Nothing -> undefined
--findIndicesWhere':: [TypeRequester] -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)] -- findIndicesWhere':: [TypeRequester] -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)]
--findIndicesWhere' (tr:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr)) -- 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 0 _ with = with replaceAtR 0 _ 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 _) _ = undefined
-- LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal 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 _) _ = undefined
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 :: 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 _ [] _ = undefined
depthLeftAndTypeAtR::TypeRequester -> Int -> Int -> (Int, TypeRequester) depthLeftAndTypeAtR :: TypeRequester -> Int -> Int -> (Int, TypeRequester)
depthLeftAndTypeAtR t 0 depthLeft = ((depthLeft - 1), t) depthLeftAndTypeAtR t 0 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 = undefined
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 = undefined
countTrsR :: TypeRequester -> Int
countTrsR:: TypeRequester -> Int
countTrsR tr@(TR t lE _) = case lE of countTrsR tr@(TR t lE _) = case lE of
Just le -> countTrs le + 1 Just le -> countTrs le + 1
Nothing -> 1 Nothing -> 1
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 :: (a -> Maybe a) -> a -> [a]

6
src/Main.hs
View File

@ -31,7 +31,7 @@ options =
( long "population-size" ( long "population-size"
<> short 'p' <> short 'p'
<> metavar "N" <> metavar "N"
<> value 100 <> value 1000
<> help "Population size" <> help "Population size"
) )
@ -49,8 +49,8 @@ main =
execParser optionsWithHelp >>= \opts -> do execParser optionsWithHelp >>= \opts -> do
hSetBuffering stdout NoBuffering hSetBuffering stdout NoBuffering
let env = AssignmentEnviroment (students prios, topics prios) let env = AssignmentEnviroment (students prios, topics prios)
let selType = Tournament 2 let selType = Tournament 20
let run' = run prios env selType 2 (5 / 100) (populationSize opts) (steps (iterations opts)) :: Producer (Int, R) IO (Population Assignment) let run' = run prios env selType 20 (5 / 100) (populationSize opts) (steps (iterations opts)) :: Producer (Int, R) IO (Population Assignment)
pop' <- pop' <-
runEffect (for run' logCsv) runEffect (for run' logCsv)
let (res, _) = bests prios 5 pop' let (res, _) = bests prios 5 pop'

19
src/Test.hs
View File

@ -19,24 +19,21 @@ import qualified Type.Reflection as Ref
main :: IO () main :: IO ()
main = do main = do
--_ <- GA.runTests -- _ <- GA.runTests
--_ <- Seminar.runTests -- _ <- Seminar.runTests
--_ <- putStrLn $ ((show (typeRepArgs (Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int -> Text))))) :: Text) -- _ <- putStrLn $ ((show (typeRepArgs (Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int -> Text))))) :: Text)
--_ <- putStrLn $ ((show (typeRepArgs (Ref.SomeTypeRep (Ref.TypeRep @(Text))))) :: Text) -- _ <- putStrLn $ ((show (typeRepArgs (Ref.SomeTypeRep (Ref.TypeRep @(Text))))) :: Text)
mwc <- createSystemRandom mwc <- createSystemRandom
r <- sampleFrom mwc $ GA.new LambdaCalculus.exampleLE r <- sampleFrom mwc $ GA.new LambdaCalculus.exampleLE
_ <- putStrLn $ LambdaCalculus.toLambdaExpressionS $ r _ <- putStrLn $ LambdaCalculus.toLambdaExpressionS $ r
r <- sampleFrom mwc $ GA.new LambdaCalculus.exampleLE r <- sampleFrom mwc $ GA.new LambdaCalculus.exampleLE
_ <- putStrLn $ LambdaCalculus.toLambdaExpressionS $ r _ <- putStrLn $ LambdaCalculus.toLambdaExpressionS $ r
--_ <- putStrLn (LambdaCalculus.toLambdaExpressionShort LambdaCalculus.testIntToClassCorrect) -- _ <- putStrLn (LambdaCalculus.toLambdaExpressionShort LambdaCalculus.testIntToClassCorrect)
--_ <- putStrLn $ ((show (LambdaCalculus.res 1)) :: Text) -- _ <- putStrLn $ ((show (LambdaCalculus.res 1)) :: Text)
--_ <- putStrLn $ ((show (LambdaCalculus.res 2)) :: Text) -- _ <- putStrLn $ ((show (LambdaCalculus.res 2)) :: Text)
--_ <- putStrLn $ ((show (LambdaCalculus.res 3)) :: Text) -- _ <- putStrLn $ ((show (LambdaCalculus.res 3)) :: Text)
return () return ()
if' :: Bool -> a -> a -> a if' :: Bool -> a -> a -> a
if' True x _ = x if' True x _ = x
if' False _ y = y if' False _ y = y