cleanup
This commit is contained in:
Johannes Merl
parent
233bc40a51
commit
57cf1452bf
|
|
@ -42,13 +42,14 @@ library
|
|||
, text
|
||||
, wl-pprint-text
|
||||
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
|
||||
exposed-modules: GA
|
||||
, Seminar
|
||||
, Pretty
|
||||
, Szenario191
|
||||
, LambdaCalculus
|
||||
, IrisDataset
|
||||
|
||||
executable haga
|
||||
build-depends: base
|
||||
|
|
@ -73,7 +74,7 @@ executable haga
|
|||
, text
|
||||
, wl-pprint-text
|
||||
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
|
||||
main-is: Main.hs
|
||||
other-modules: GA
|
||||
|
|
@ -81,6 +82,7 @@ executable haga
|
|||
, Pretty
|
||||
, Szenario191
|
||||
, LambdaCalculus
|
||||
, IrisDataset
|
||||
|
||||
executable haga-test
|
||||
build-depends: base
|
||||
|
|
@ -106,7 +108,7 @@ executable haga-test
|
|||
, text
|
||||
, wl-pprint-text
|
||||
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
|
||||
main-is: Test.hs
|
||||
other-modules: GA
|
||||
|
|
@ -114,3 +116,4 @@ executable haga-test
|
|||
, Pretty
|
||||
, Szenario191
|
||||
, LambdaCalculus
|
||||
, IrisDataset
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ import Data.Random
|
|||
import Pipes
|
||||
import Pretty
|
||||
import Protolude
|
||||
import System.Random.MWC (create)
|
||||
import System.Random.MWC (create, createSystemRandom)
|
||||
import Test.QuickCheck hiding (sample, shuffle)
|
||||
import Test.QuickCheck.Instances ()
|
||||
import Test.QuickCheck.Monadic
|
||||
|
|
@ -211,7 +211,7 @@ run ::
|
|||
Termination i ->
|
||||
Producer (Int, R) IO (Population i)
|
||||
run eval env selectionType nParents pElite nPop term = do
|
||||
mwc <- liftIO create
|
||||
mwc <- liftIO createSystemRandom
|
||||
let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
|
||||
firstPop <- liftIO $ smpl $ (population env nPop)
|
||||
_ <- liftIO $ putText $ pretty $ NE.head firstPop
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
|
@ -5,23 +6,16 @@
|
|||
{-# LANGUAGE Trustworthy #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
|
||||
module LambdaCalculus where
|
||||
|
||||
import Data.Dynamic
|
||||
import Data.List (foldr1, last, lookup, zipWith3, (!!), (\\))
|
||||
import Data.List.Extra (delete, nubOrd, nubOrdOn)
|
||||
import Data.Tuple.Extra
|
||||
import Data.List (foldr1, last)
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe
|
||||
import Data.Random
|
||||
import qualified Data.ByteString.Lazy as B
|
||||
import Data.Csv
|
||||
import Data.Proxy
|
||||
import qualified Data.Text as T
|
||||
import Data.Tuple.Extra
|
||||
import Data.Typeable
|
||||
import GA
|
||||
import Pretty
|
||||
|
|
@ -29,7 +23,6 @@ import Protolude
|
|||
import Test.QuickCheck hiding (sample, shuffle)
|
||||
import Test.QuickCheck.Monadic (assert, monadicIO)
|
||||
import qualified Type.Reflection as Ref
|
||||
import qualified Language.Haskell.Interpreter as Hint
|
||||
|
||||
data ExpressionWeights = ExpressionWeights
|
||||
{ lambdaSpucker :: Int,
|
||||
|
|
@ -47,19 +40,7 @@ data LambdaEnviroment = LambdaEnviroment
|
|||
weights :: ExpressionWeights
|
||||
}
|
||||
|
||||
data LamdaExecutionEnv = LamdaExecutionEnv {
|
||||
-- For now these need to define all available functions and types. Generic functions can be used.
|
||||
imports :: [Text],
|
||||
--Path to a CSV file containing the training dataset
|
||||
trainingDataset :: FilePath,
|
||||
--Path to a CSV file containing the dataset results
|
||||
trainingDatasetRes :: FilePath,
|
||||
exTargetType :: TypeRep,
|
||||
-- todo: kindaHacky
|
||||
results :: Map TypeRequester R
|
||||
}
|
||||
|
||||
showSanifid:: Show a => a -> Text
|
||||
showSanifid :: (Show a) => a -> Text
|
||||
showSanifid var = T.replace " -> " "To" (show var)
|
||||
|
||||
exampleLE :: LambdaEnviroment
|
||||
|
|
@ -104,8 +85,6 @@ asList (Symbol _ trs _) = trs
|
|||
asList (Var _ _ trs _) = trs
|
||||
asList (Constan _) = []
|
||||
|
||||
|
||||
|
||||
data TypeRequester = TR TypeRep (Maybe LambdaExpression) BoundVars deriving (Eq, Ord)
|
||||
|
||||
toLambdaExpressionS :: TypeRequester -> Text
|
||||
|
|
@ -229,7 +208,7 @@ genLambdaVar env@(LambdaEnviroment functions constants _ _ weights) depthLeft ta
|
|||
let availTypes = filter (doTypesMatch target) boundVar
|
||||
choosenType <- randomElement $ availTypes
|
||||
let tCount = count boundVar choosenType
|
||||
indexV <- uniform 0 (tCount-1)
|
||||
indexV <- uniform 0 (tCount - 1)
|
||||
ret <- genLambdaVar' choosenType choosenType indexV [] env depthLeft target boundVar
|
||||
return ret
|
||||
|
||||
|
|
@ -251,27 +230,18 @@ instance Environment TypeRequester LambdaEnviroment where
|
|||
return tr
|
||||
|
||||
mutate env@(LambdaEnviroment _ _ _ maxDepth _) tr = do
|
||||
let trCount = countTrsR(tr)
|
||||
let trCount = countTrsR (tr)
|
||||
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
|
||||
return $ replaceAtR selectedTR tr res
|
||||
|
||||
nX _ = 3 --todo!
|
||||
nX _ = 3 -- todo!
|
||||
|
||||
crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do
|
||||
return Nothing
|
||||
|
||||
instance Evaluator TypeRequester LamdaExecutionEnv where
|
||||
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}
|
||||
|
||||
-- TODO: crossover!
|
||||
-- let trCount = countTrsR tr1
|
||||
-- selectedIndex1 <- uniform 1 trCount
|
||||
-- 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
|
||||
-- (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
|
||||
--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))
|
||||
-- Nothing -> undefined
|
||||
|
||||
--findIndicesWhere':: [TypeRequester] -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)]
|
||||
--findIndicesWhere' (tr:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr))
|
||||
-- findIndicesWhere':: [TypeRequester] -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)]
|
||||
-- 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 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
|
||||
|
||||
-- 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 (LambdaSchlucker tr bv) with = LambdaSchlucker (replaceAtR i tr with) bv
|
||||
replaceAt i le@(Symbol cv _ bv) with = Symbol cv trs bv where trs = replaceInSubtreeWithIndex i (asList le) with
|
||||
replaceAt i le@(Var tr ix _ bv) with = Var tr ix trs bv where trs = replaceInSubtreeWithIndex i (asList le) with
|
||||
replaceAt _ (Constan _) _ = undefined
|
||||
|
||||
|
||||
|
||||
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
|
||||
|
||||
depthLeftAndTypeAtR::TypeRequester -> Int -> Int -> (Int, TypeRequester)
|
||||
depthLeftAndTypeAtR :: TypeRequester -> Int -> Int -> (Int, TypeRequester)
|
||||
depthLeftAndTypeAtR t 0 depthLeft = ((depthLeft - 1), t)
|
||||
depthLeftAndTypeAtR (TR _ (Just le) _) indexLeft depthLeft = depthLeftAndTypeAt le (indexLeft - 1) (depthLeft - 1)
|
||||
depthLeftAndTypeAtR (TR _ Nothing _) indexLeft depthLeft = undefined
|
||||
|
||||
|
||||
depthLeftAndTypeAt :: LambdaExpression -> Int -> Int -> (Int, TypeRequester)
|
||||
depthLeftAndTypeAt le indexLeft depthLeft = depthLeftAndTypeInSubtreeWithIndex (asList le) indexLeft depthLeft
|
||||
|
||||
depthLeftAndTypeInSubtreeWithIndex :: [TypeRequester] -> Int -> Int -> (Int, TypeRequester)
|
||||
depthLeftAndTypeInSubtreeWithIndex (tr:trs) indexLeft depthLeft = if countTrsR tr >= indexLeft then depthLeftAndTypeAtR tr indexLeft depthLeft else depthLeftAndTypeInSubtreeWithIndex trs (indexLeft - countTrsR tr) depthLeft
|
||||
depthLeftAndTypeInSubtreeWithIndex (tr : trs) indexLeft depthLeft = if countTrsR tr >= indexLeft then depthLeftAndTypeAtR tr indexLeft depthLeft else depthLeftAndTypeInSubtreeWithIndex trs (indexLeft - countTrsR tr) depthLeft
|
||||
depthLeftAndTypeInSubtreeWithIndex [] indexLeft depthLeft = undefined
|
||||
|
||||
|
||||
countTrsR:: TypeRequester -> Int
|
||||
countTrsR :: TypeRequester -> Int
|
||||
countTrsR tr@(TR t lE _) = case lE of
|
||||
Just le -> countTrs le + 1
|
||||
Nothing -> 1
|
||||
|
||||
countTrs:: LambdaExpression -> Int
|
||||
countTrs :: LambdaExpression -> Int
|
||||
countTrs le = sum (map countTrsR (asList le))
|
||||
|
||||
repeatedly :: (a -> Maybe a) -> a -> [a]
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ options =
|
|||
( long "population-size"
|
||||
<> short 'p'
|
||||
<> metavar "N"
|
||||
<> value 100
|
||||
<> value 1000
|
||||
<> help "Population size"
|
||||
)
|
||||
|
||||
|
|
@ -49,8 +49,8 @@ main =
|
|||
execParser optionsWithHelp >>= \opts -> do
|
||||
hSetBuffering stdout NoBuffering
|
||||
let env = AssignmentEnviroment (students prios, topics prios)
|
||||
let selType = Tournament 2
|
||||
let run' = run prios env selType 2 (5 / 100) (populationSize opts) (steps (iterations opts)) :: Producer (Int, R) IO (Population Assignment)
|
||||
let selType = Tournament 20
|
||||
let run' = run prios env selType 20 (5 / 100) (populationSize opts) (steps (iterations opts)) :: Producer (Int, R) IO (Population Assignment)
|
||||
pop' <-
|
||||
runEffect (for run' logCsv)
|
||||
let (res, _) = bests prios 5 pop'
|
||||
|
|
|
|||
19
src/Test.hs
19
src/Test.hs
|
|
@ -19,24 +19,21 @@ import qualified Type.Reflection as Ref
|
|||
|
||||
main :: IO ()
|
||||
main = do
|
||||
--_ <- GA.runTests
|
||||
--_ <- Seminar.runTests
|
||||
--_ <- putStrLn $ ((show (typeRepArgs (Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int -> Text))))) :: Text)
|
||||
--_ <- putStrLn $ ((show (typeRepArgs (Ref.SomeTypeRep (Ref.TypeRep @(Text))))) :: Text)
|
||||
-- _ <- GA.runTests
|
||||
-- _ <- Seminar.runTests
|
||||
-- _ <- putStrLn $ ((show (typeRepArgs (Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int -> Text))))) :: Text)
|
||||
-- _ <- putStrLn $ ((show (typeRepArgs (Ref.SomeTypeRep (Ref.TypeRep @(Text))))) :: Text)
|
||||
mwc <- createSystemRandom
|
||||
r <- sampleFrom mwc $ GA.new LambdaCalculus.exampleLE
|
||||
_ <- putStrLn $ LambdaCalculus.toLambdaExpressionS $ r
|
||||
r <- sampleFrom mwc $ GA.new LambdaCalculus.exampleLE
|
||||
_ <- putStrLn $ LambdaCalculus.toLambdaExpressionS $ r
|
||||
--_ <- putStrLn (LambdaCalculus.toLambdaExpressionShort LambdaCalculus.testIntToClassCorrect)
|
||||
--_ <- putStrLn $ ((show (LambdaCalculus.res 1)) :: Text)
|
||||
--_ <- putStrLn $ ((show (LambdaCalculus.res 2)) :: Text)
|
||||
--_ <- putStrLn $ ((show (LambdaCalculus.res 3)) :: Text)
|
||||
-- _ <- putStrLn (LambdaCalculus.toLambdaExpressionShort LambdaCalculus.testIntToClassCorrect)
|
||||
-- _ <- putStrLn $ ((show (LambdaCalculus.res 1)) :: Text)
|
||||
-- _ <- putStrLn $ ((show (LambdaCalculus.res 2)) :: Text)
|
||||
-- _ <- putStrLn $ ((show (LambdaCalculus.res 3)) :: Text)
|
||||
return ()
|
||||
|
||||
if' :: Bool -> a -> a -> a
|
||||
if' True x _ = x
|
||||
if' False _ y = y
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user