Add Seminar module draft and SS19 example

src/Main.hs

@@ -4,5 +4,14 @@
 import Protolude
 
 
-main
+import GA
-  = putStrLn "It runs."
+import SS19
+
+
+main = do
+  pop <- mkPop
+  ga' 2 1 pop (\_ t -> t > 100) 10
+  putStrLn "Done."
+
+
+mkPop = population 100 (I prios [])

src/Seminar.hs

@@ -0,0 +1,155 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Seminar where
+
+import Data.List ((!!), lookup, nub, zipWith3)
+import Data.Random
+import Data.Random.Distribution.Uniform
+import qualified Data.Text as T
+import GA
+import Pretty
+import Protolude
+import Test.QuickCheck hiding (sample, shuffle)
+import Test.QuickCheck.Instances
+
+data Name
+  = N
+      { firstName :: Text,
+        lastName :: Text
+      }
+  deriving (Eq, Show)
+
+instance Arbitrary Name where
+  arbitrary = N <$> arbitrary <*> arbitrary
+
+instance Pretty Name where
+  pretty (N f l) = f <> " " <> l
+
+type EMail = Text
+
+data Student
+  = S
+      { name :: Name,
+        email :: EMail
+      }
+  deriving (Eq, Show)
+
+instance Arbitrary Student where
+  arbitrary = S <$> arbitrary <*> arbitrary
+
+instance Pretty Student where
+  pretty (S n e) = pretty n <> " <" <> e <> ">"
+
+{-|
+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
+  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 Arbitrary Topic where
+  arbitrary = oneof [Topic <$> arbitrary, return NoTopic]
+
+instance Pretty Topic where
+  pretty (Topic s) = s
+  pretty NoTopic = "Kein Thema"
+
+topicToMaybe (Topic x) = Just x
+topicToMaybe NoTopic = Nothing
+
+type Priorities = [(Student, [(Topic, Int)])]
+
+students :: Priorities -> [Student]
+students = fmap fst
+
+topics :: Priorities -> [Topic]
+topics p = topics' ++ padding
+  where
+    padding = replicate (length (students p) - length topics') NoTopic
+    topics' = nub . join $ fmap fst . snd <$> p
+
+{-|
+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
+
+type Assignment = [(Student, Topic)]
+
+data I = I Priorities Assignment
+  deriving (Eq, Show)
+
+instance Pretty I where
+  pretty i@(I p a) =
+    T.unlines (gene <$> a)
+    where
+      gene :: (Student, Topic) -> Text
+      gene (s, t) =
+        pretty s <> ": " <> pretty t <> prio s t
+      prio :: Student -> Topic -> Text
+      prio s t = " (" <> show (prioOf p s t) <> ")"
+
+instance Individual I where
+
+  new (I p _) =
+    sample $ I p . zip (nub $ students p) <$> shuffle (nub $ topics p)
+
+  fitness (I p a) =
+    return . (1 /) . sum $ fromIntegral . uncurry (prioOf p) <$> a
+
+  mutate (I p a) = do
+    x <- sample $ Uniform 0 (length a - 1)
+    y <- sample $ Uniform 0 (length a - 1)
+    return . I p $ switch x y a
+
+  {-|
+  Borrowed from TSP: Crossover cuts the parents in two and swaps them (if this
+  does not create an invalid offspring).
+  
+  TODO Assumes that both individuals are based on the same priorities.
+  
+  TODO Require type-wise that both Assignments are of the same length.
+  -}
+  crossover1 (I p a1) (I _ a2) = do
+    let l = fromIntegral $ min (length a1) (length a2) :: Double
+    x <- sample $ Uniform 0 l
+    let a1' = zipWith3 (f x) a1 a2 [0 ..]
+    let a2' = zipWith3 (f x) a2 a1 [0 ..]
+    if valid a1' && valid a2'
+      then return . Just $ (I p a1', I p a2')
+      else return Nothing
+    where
+      f x v1 v2 i = if i <= x then v1 else v2
+
+switch :: Int -> Int -> Assignment -> Assignment
+switch i' j' xs
+  | 0 <= i' && i' < length xs && 0 <= j' && j' < length xs =
+    let i = min i' j'
+        j = max i' j'
+        ei = xs !! i
+        ej = xs !! j
+        left = take i xs
+        middle = take (j - i - 1) $ drop (i + 1) xs
+        right = drop (j + 1) xs
+     in left ++ [(fst ei, snd ej)] ++ middle ++ [(fst ej, snd ei)] ++ right
+  | otherwise = xs
+
+valid :: Assignment -> Bool
+valid a =
+  length a == length (nub $ fst <$> a)
+    && length a == length (nub $ snd <$> a)