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)
-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.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 {
+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)
 
 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
@@ -262,16 +241,7 @@ instance Environment TypeRequester LambdaEnviroment where
   crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do
     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
 --  selectedIndex1 <- uniform 1 trCount
 --  let (depthAt, selectedTr1@(TR trep _ bound)) = depthLeftAndTypeAtR tr selectedTR maxDepth
@@ -279,30 +249,8 @@ 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
 --                            Just le -> (tr, indx+1):(findIndicesWhere' (asList le) filte (indx+1))
@@ -311,14 +259,11 @@ evalResult ex tr = do
 -- 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 0 _ with = with
 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 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
@@ -326,8 +271,6 @@ replaceAt i le@(Symbol cv _ bv) with = Symbol cv trs bv where trs = replaceInSub
 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 _ [] _ = undefined
@@ -337,7 +280,6 @@ 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
 
@@ -345,7 +287,6 @@ depthLeftAndTypeInSubtreeWithIndex :: [TypeRequester] -> Int -> Int -> (Int, Typ
 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 tr@(TR t lE _) = case lE of
   Just le -> countTrs le + 1

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 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' <-
       runEffect (for run' logCsv)
     let (res, _) = bests prios 5 pop'

src/Test.hs

@@ -37,6 +37,3 @@ main = do
 if' :: Bool -> a -> a -> a
 if' True x _ = x
 if' False _ y = y
-
-
-