cleanup

haga.cabal

@@ -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

src/GA.hs

@@ -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

src/LambdaCalculus.hs

@@ -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 :: 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
 
-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
-
+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
+  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]

src/Main.hs

@@ -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'

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
-
-
-