diff --git a/default.nix b/default.nix index 6e2303d..a3a01db 100644 --- a/default.nix +++ b/default.nix @@ -1,14 +1,21 @@ -{ mkDerivation, base, monad-loops, MonadRandom, protolude -, QuickCheck, quickcheck-instances, random, random-fu +{ mkDerivation, base, bytestring, cassava, monad-loops, MonadRandom +, protolude, QuickCheck, quickcheck-instances, random, random-fu , random-shuffle, stdenv, text }: mkDerivation { - pname = "GA-PFP"; + pname = "ga"; version = "0.1.0.0"; src = ./.; + isLibrary = true; + isExecutable = true; libraryHaskellDepends = [ - base monad-loops MonadRandom protolude QuickCheck + base cassava monad-loops MonadRandom protolude QuickCheck quickcheck-instances random random-fu random-shuffle text ]; + executableHaskellDepends = [ + base bytestring cassava monad-loops MonadRandom protolude + QuickCheck quickcheck-instances random random-fu random-shuffle + text + ]; license = stdenv.lib.licenses.gpl3; } diff --git a/ga.cabal b/ga.cabal index 79ead0c..e3cf19b 100644 --- a/ga.cabal +++ b/ga.cabal @@ -30,6 +30,7 @@ library , Seminar , Pretty , SS19 + , WS19 executable ga @@ -43,7 +44,6 @@ executable ga , QuickCheck , quickcheck-instances , text - , protolude default-language: Haskell2010 hs-source-dirs: src main-is: Main.hs @@ -51,3 +51,4 @@ executable ga , Seminar , Pretty , SS19 + , WS19 diff --git a/src/GA.hs b/src/GA.hs index 5c43467..c6a3a42 100644 --- a/src/GA.hs +++ b/src/GA.hs @@ -4,6 +4,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} module GA where @@ -161,7 +162,13 @@ Runs the GA and prints the @nResult@ best individuals. ga' nParents nX pop term nResult = do pop <- ga nParents nX pop term res <- bests nResult pop - sequence $ putText . pretty <$> res + sequence $ format <$> res + where + -- TODO this has to be done nicer + format :: (Individual i, MonadIO m, Pretty i) => i -> m () + format s = do + f <- liftIO $ fitness s + putText $ show f <> "\n" <> pretty s {-| Runs the GA, using in each iteration @@ -194,9 +201,11 @@ ga nParents nX pop term = ga' nParents nX pop term 0 -- traceShow (length is') $ return () iWorsts <- worst nParents pop -- traceShow (length iWorsts) $ return () + let popClean = foldr L.delete (NE.toList . unPop $ pop) iWorsts + -- traceShow (length popClean) $ return () -- for the fromList to not fail, n < length pop -- replace the worst ones - let pop' = Pop $ i :| is' <> foldr L.delete (NE.toList . unPop $ pop) iWorsts + let pop' = Pop $ i :| is' <> popClean -- replace fitness proportionally -- let pop' = Pop <$> proportionate (length pop) (pop <> Pop is') if term pop' t diff --git a/src/Main.hs b/src/Main.hs index d1da685..d254cf6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,17 +1,12 @@ {-# LANGUAGE NoImplicitPrelude #-} - +{-# LANGUAGE OverloadedStrings #-} import Protolude - - -import GA -import SS19 - +import WS19 main = do pop <- mkPop - ga' 2 1 pop (\_ t -> t > 100) 10 - putStrLn "Done." - + ga' 2 1 pop (steps 10000) 10 + putText "Done." mkPop = population 100 (I prios []) diff --git a/src/Seminar.hs b/src/Seminar.hs index 0cb11a6..1233237 100644 --- a/src/Seminar.hs +++ b/src/Seminar.hs @@ -45,39 +45,42 @@ instance Pretty Student where The seminar GA is about giving topics to students. If there are not enough topics, some students might get assigned 'NoTopic'. -} -data Topic - = Topic Text - | NoTopic +data T + = T Text + | NoT deriving (Show) {-| 'Topic' is not 'Maybe' because this 'Eq' instance is different ('Nothing' @==@ 'Nothing' but 'NoTopic' @/=@ 'NoTopic'). -} -instance Eq Topic where - Topic x == Topic y = x == y - NoTopic == _ = False - _ == NoTopic = False +instance Eq T where + T x == T y = x == y + -- NoT == _ = False + -- _ == NoT = False + NoT == NoT = True + NoT == _ = False + _ == NoT = False -instance Arbitrary Topic where - arbitrary = oneof [Topic <$> arbitrary, return NoTopic] +instance Arbitrary T where + arbitrary = oneof [T <$> arbitrary, return NoT] -instance Pretty Topic where - pretty (Topic s) = s - pretty NoTopic = "Kein Thema" +instance Pretty T where + pretty (T s) = s + pretty NoT = "Kein Thema" -topicToMaybe (Topic x) = Just x -topicToMaybe NoTopic = Nothing +topicToMaybe (T x) = Just x +topicToMaybe NoT = Nothing -type Priorities = [(Student, [(Topic, Int)])] +type Priorities = [(Student, [(T, Int)])] students :: Priorities -> [Student] students = fmap fst -topics :: Priorities -> [Topic] +topics :: Priorities -> [T] topics p = topics' ++ padding where - padding = replicate (length (students p) - length topics') NoTopic + padding = replicate (length (students p) - length topics') NoT topics' = nub . join $ fmap fst . snd <$> p {-| @@ -85,11 +88,11 @@ The priority of topics that have not been assigned a priority is the sum of all priorities given by all the students. The priority of 'NoTopic' is one more than that value. -} -prioOf :: Priorities -> Student -> Topic -> Int -prioOf p _ NoTopic = (1 +) . sum $ (sum . fmap snd) . snd <$> p -prioOf p s t = maybe (prioOf p s NoTopic) identity $ lookup s p >>= lookup t +prioOf :: Priorities -> Student -> T -> Int +prioOf p _ NoT = (1 +) . sum $ (sum . fmap snd) . snd <$> p +prioOf p s t = maybe (prioOf p s NoT) identity $ lookup s p >>= lookup t -type Assignment = [(Student, Topic)] +type Assignment = [(Student, T)] data I = I Priorities Assignment deriving (Eq, Show) @@ -98,10 +101,10 @@ instance Pretty I where pretty i@(I p a) = T.unlines (gene <$> a) where - gene :: (Student, Topic) -> Text + gene :: (Student, T) -> Text gene (s, t) = pretty s <> ": " <> pretty t <> prio s t - prio :: Student -> Topic -> Text + prio :: Student -> T -> Text prio s t = " (" <> show (prioOf p s t) <> ")" instance Individual I where @@ -110,7 +113,8 @@ instance Individual I where sample $ I p . zip (nub $ students p) <$> shuffle (nub $ topics p) fitness (I p a) = - return . (1 /) . sum $ fromIntegral . uncurry (prioOf p) <$> a + return . (fromIntegral (prioOf p undefined NoT) /) . sum + $ fromIntegral . uncurry (prioOf p) <$> a mutate (I p a) = do x <- sample $ Uniform 0 (length a - 1)