Rename Topic to T, fix T Eq instance, fix fitness calculation

default.nix

@@ -1,14 +1,21 @@
-{ mkDerivation, base, monad-loops, MonadRandom, protolude
+{ mkDerivation, base, bytestring, cassava, monad-loops, MonadRandom
-, QuickCheck, quickcheck-instances, random, random-fu
+, 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;
 }

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

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

src/Main.hs

@@ -1,17 +1,12 @@
 {-# LANGUAGE NoImplicitPrelude #-}
-
+{-# LANGUAGE OverloadedStrings #-}
 
 import Protolude
-
+import WS19
-
-import GA
-import SS19
-
 
 main = do
   pop <- mkPop
-  ga' 2 1 pop (\_ t -> t > 100) 10
+  ga' 2 1 pop (steps 10000) 10
-  putStrLn "Done."
+  putText "Done."
-
 
 mkPop = population 100 (I prios [])

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
+data T
-  = Topic Text
+  = T Text
-  | NoTopic
+  | NoT
   deriving (Show)
 
 {-|
 'Topic' is not 'Maybe' because this 'Eq' instance is different ('Nothing' @==@
 'Nothing' but 'NoTopic' @/=@ 'NoTopic').
 -}
-instance Eq Topic where
+instance Eq T where
-  Topic x == Topic y = x == y
+  T x == T y = x == y
-  NoTopic == _ = False
+  -- NoT == _ = False
-  _ == NoTopic = False
+  -- _ == NoT = False
+  NoT == NoT = True
+  NoT == _ = False
+  _ == NoT = False
 
-instance Arbitrary Topic where
+instance Arbitrary T where
-  arbitrary = oneof [Topic <$> arbitrary, return NoTopic]
+  arbitrary = oneof [T <$> arbitrary, return NoT]
 
-instance Pretty Topic where
+instance Pretty T where
-  pretty (Topic s) = s
+  pretty (T s) = s
-  pretty NoTopic = "Kein Thema"
+  pretty NoT = "Kein Thema"
 
-topicToMaybe (Topic x) = Just x
+topicToMaybe (T x) = Just x
-topicToMaybe NoTopic = Nothing
+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 :: Priorities -> Student -> T -> Int
-prioOf p _ NoTopic = (1 +) . sum $ (sum . fmap snd) . snd <$> p
+prioOf p _ NoT = (1 +) . sum $ (sum . fmap snd) . snd <$> p
-prioOf p s t = maybe (prioOf p s NoTopic) identity $ lookup s p >>= lookup t
+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)