From 0f428bea1617d90c1bfd28292203ef4b1cc50a11 Mon Sep 17 00:00:00 2001
From: Johannes Merl <johannes.merl@mischok.de>
Date: Mon, 12 Feb 2024 23:37:55 +0100
Subject: [PATCH] invent proper enviroment type for individual generation

---
 src/GA.hs      | 290 ++++++++++++++++++++++++++++---------------------
 src/Main.hs    |  11 +-
 src/Seminar.hs | 106 +++++++++---------
 3 files changed, 226 insertions(+), 181 deletions(-)

diff --git a/src/GA.hs b/src/GA.hs
index 937190c..2dd423f 100644
--- a/src/GA.hs
+++ b/src/GA.hs
@@ -1,12 +1,11 @@
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
+
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE NoImplicitPrelude #-}
-
+{-# LANGUAGE MultiParamTypeClasses #-}
 -- |
 -- Module      : GA
 -- Description : Abstract genetic algorithm
@@ -25,11 +24,12 @@ module GA where
 import Control.Arrow hiding (first, second)
 import Data.List.NonEmpty ((<|))
 import qualified Data.List.NonEmpty as NE
-import qualified Data.List.NonEmpty.Extra as NE (appendl, sortOn)
+import qualified Data.List.NonEmpty.Extra as NE (appendl)
 import Data.Random
 import System.Random.MWC (create)
 import Pipes
 import Protolude
+import Pretty
 import Test.QuickCheck hiding (sample, shuffle)
 import Test.QuickCheck.Instances ()
 import Test.QuickCheck.Monadic
@@ -41,33 +41,28 @@ type N = Int
 
 type R = Double
 
-class Eq i => Individual i where
-  -- |
-  --  Generates a completely random individual given an existing individual.
-  --
-  --  We have to add @i@ here as a parameter in order to be able to inject stuff.
 
-  -- TODO This (and also, Seminar.I, which contains an ugly parameter @p@) has
-  -- to be done nicer!
-  new :: i -> RVar i
+-- |
+--  An Environment that Individuals of type i can be created from
+--  It stores all information required to create and change Individuals correctly
+--
+class (Eq e, Pretty e, Individual i) => Environment i e where
+  -- |
+  --  Generates a completely random individual.
+  --
+  new :: e -> RVar i
 
   -- |
   --  Generates a random population of the given size.
-  population :: N -> i -> RVar (Population i)
-  population n i
+  population :: e -> N -> RVar (Population i)
+  population env n
     | n <= 0 = undefined
-    | otherwise = NE.fromList <$> replicateM n (new i)
+    | otherwise = NE.fromList <$> replicateM n (new env)
 
-  mutate :: i -> RVar i
+  mutate :: e -> i -> RVar i
 
-  crossover1 :: i -> i -> RVar (Maybe (i, i))
+  crossover1 :: e -> i -> i -> RVar (Maybe (i, i))
 
-  -- |
-  --  An individual's fitness. Higher values are considered “better”.
-  --
-  --  We explicitely allow fitness values to be have any sign (see, for example,
-  --  'proportionate1').
-  fitness :: i -> R
 
   -- |
   --  Performs an n-point crossover.
@@ -75,24 +70,28 @@ class Eq i => Individual i where
   --  Given the function for single-point crossover, 'crossover1', this function can
   --  be derived through recursion and a monad combinator (which is also the default
   --  implementation).
-  crossover :: N -> i -> i -> RVar (Maybe (i, i))
-  crossover n i1 i2
+  crossover :: e -> N -> i -> i -> RVar (Maybe (i, i))
+  crossover env n i1 i2
     | n <= 0 = return $ Just (i1, i2)
     | otherwise = do
-        isM <- crossover1 i1 i2
-        maybe (return Nothing) (uncurry (crossover (n - 1))) isM
+        isM <- crossover1 env i1 i2
+        maybe (return Nothing) (uncurry (crossover env (n - 1))) isM
 
 -- |
--- Needed for QuickCheck tests, for now, a very simplistic implementation should
--- suffice.
-instance Individual Integer where
-  new _ = uniform 0 (0 + 100000)
+--  An Evaluator that Individuals of type i can be evaluated by
+--  It stores all information required to evaluate an individuals fitness
+--
+class (Eq e, Individual i) => Evaluator i e where
+  -- |
+  --  An individual's fitness. Higher values are considered “better”.
+  --
+  --  We explicitely allow fitness values to be have any sign (see, for example,
+  --  'proportionate1').
+  fitness :: e -> i -> R
 
-  mutate i = uniform (i - 10) (i + 10)
+class (Pretty i, Eq i) => Individual i
 
-  crossover1 i1 i2 = return $ Just (i1 - i2, i2 - i1)
 
-  fitness = fromIntegral . negate
 
 -- |
 -- Populations are just basic non-empty lists.
@@ -101,32 +100,24 @@ type Population i = NonEmpty i
 -- |
 -- Produces offspring circularly from the given list of parents.
 children ::
-  (Individual i) =>
+  (Individual i, Environment i e) =>
+  e ->
   -- | The @nX@ of the @nX@-point crossover operator
   N ->
   NonEmpty i ->
   RVar (NonEmpty i)
-children _ (i :| []) = (:| []) <$> mutate i
-children nX (i1 :| [i2]) = children2 nX i1 i2
-children nX (i1 :| i2 : is') =
-  (<>) <$> children2 nX i1 i2 <*> children nX (NE.fromList is')
+children e _ (i :| []) = (:| []) <$> mutate e i
+children e nX (i1 :| [i2]) = children2 e nX i1 i2
+children e nX (i1 :| i2 : is') =
+  (<>) <$> children2 e nX i1 i2 <*> children e nX (NE.fromList is')
 
-prop_children_asManyAsParents ::
-  (Individual a, Show a) => N -> NonEmpty a -> Property
-prop_children_asManyAsParents nX is =
-  again $
-    monadicIO $
-      do
-        mwc <- Test.QuickCheck.Monadic.run create
-        is' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (children nX is)
-        return $ counterexample (show is') $ length is' == length is
 
-children2 :: (Individual i) => N -> i -> i -> RVar (NonEmpty i)
-children2 nX i1 i2 = do
+children2 :: (Individual i, Environment i e) => e -> N -> i -> i -> RVar (NonEmpty i)
+children2 e nX i1 i2 = do
   -- TODO Add crossover probability?
-  (i3, i4) <- fromMaybe (i1, i2) <$> crossover nX i1 i2
-  i5 <- mutate i3
-  i6 <- mutate i4
+  (i3, i4) <- fromMaybe (i1, i2) <$> crossover e nX i1 i2
+  i5 <- mutate e i3
+  i6 <- mutate e i4
   return $ i5 :| [i6]
 
 -- |
@@ -153,31 +144,16 @@ bestsBy' k f pop
   | k <= 0 = bestsBy' 1 f pop
   | otherwise = NE.take k $ map fst $ NE.sortBy (comparing (Down . snd)) $ map (\i -> (i, f i)) pop
 
-prop_bestsBy_isBestsBy' :: Individual a => Int -> Population a -> Property
-prop_bestsBy_isBestsBy' k pop =
-  k > 0 ==>
-    monadicIO $
-      do
-        let a = fst $ bestsBy k fitness pop
-        let b = bestsBy' k fitness pop
-        assert $ NE.toList a == b
-
-prop_bestsBy_lengths :: Individual a => Int -> Population a -> Property
-prop_bestsBy_lengths k pop =
-  k > 0 ==> monadicIO $ do
-    let (bests, rest) = bestsBy k fitness pop
-    assert $
-      length bests == min k (length pop) && length bests + length rest == length pop
 
 -- |
 -- The @k@ worst individuals in the population (and the rest of the population).
-worst :: (Individual i) => N -> Population i -> (NonEmpty i, [i])
-worst k pop = bestsBy k (negate . fitness) pop
+worst :: (Individual i, Evaluator i e) => e -> N -> Population i -> (NonEmpty i, [i])
+worst e k = bestsBy k (negate . fitness e)
 
 -- |
 -- The @k@ best individuals in the population (and the rest of the population).
-bests :: (Individual i) => N -> Population i -> (NonEmpty i, [i])
-bests k pop = bestsBy k fitness pop
+bests :: (Individual i, Evaluator i e) => e -> N -> Population i -> (NonEmpty i, [i])
+bests e k = bestsBy k (fitness e)
 
 -- TODO add top x percent parent selection (select n guys, sort by fitness first)
 
@@ -188,7 +164,9 @@ bests k pop = bestsBy k fitness pop
 -- elitist, even if the percentage is 0 or low enough for rounding to result in 0
 -- elitists).
 stepSteady ::
-  (Individual i) =>
+  (Individual i, Evaluator i eval, Environment i env ) =>
+  eval ->
+  env ->
   -- | Mechanism for selecting parents
   Selection RVar i ->
   -- | Number of parents @nParents@ for creating @nParents@ children
@@ -199,46 +177,34 @@ stepSteady ::
   R ->
   Population i ->
   RVar (Population i)
-stepSteady select nParents nX pElite pop = do
+stepSteady eval env select nParents nX pElite pop = do
   -- TODO Consider keeping the fitness evaluations already done for pop (so we
   -- only reevaluate iChildren)
   iParents <- select nParents pop
-  iChildren <- NE.filter (`notElem` pop) <$> children nX iParents
+  iChildren <- NE.filter (`notElem` pop) <$> children env nX iParents
   let pop' = pop `NE.appendl` iChildren
   let eliteSize = floor . (pElite *) . fromIntegral $ NE.length pop
-  let (elitists, rest) = bests eliteSize pop'
+  let (elitists, rest) = bests eval eliteSize pop'
   case rest of
     [] -> return elitists
-    otherwise ->
+    _notEmpty ->
       -- NOTE 'bests' always returns at least one individual, thus we need this
       -- slightly ugly branching
       if length elitists == length pop
         then return elitists
         else
-          return $ elitists <> (fst $ bests (length pop - length elitists) (NE.fromList rest))
-
-prop_stepSteady_constantPopSize ::
-  (Individual a, Show a) => NonEmpty a -> Property
-prop_stepSteady_constantPopSize pop =
-  forAll
-    ( (,)
-        <$> choose (1, length pop)
-        <*> choose (1, length pop)
-    )
-    $ \(nParents, nX) -> monadicIO $ do
-      let pElite = 0.1
-      mwc <- Test.QuickCheck.Monadic.run create
-      pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (stepSteady (tournament 4) nParents nX pElite pop)
-      return . counterexample (show pop') $ length pop' == length pop
+          return $ elitists <> (fst $ bests eval (length pop - length elitists) (NE.fromList rest))
 
 -- |
--- Given an initial population, runs the GA until the termination criterion is
+-- Given an Enviroment and Evaluator, runs the GA until the termination criterion is
 -- fulfilled.
 --
 -- Uses the pipes library to, in each step, 'Pipes.yield' the currently best known
 -- solution.
 run ::
-  (Individual i) =>
+  (Individual i, Evaluator i eval, Environment i env ) =>
+  eval ->
+  env ->
   -- | Mechanism for selecting parents
   Selection RVar i ->
   -- | Number of parents @nParents@ for creating @nParents@ children
@@ -247,21 +213,22 @@ run ::
   N ->
   -- | Elitism ratio @pElite@
   R ->
-  RVar (Population i) ->
+  -- | Population size
+  N ->
   Termination i ->
   Producer (Int, R) IO (Population i)
-run select nParents nX pElite pop term = do
+run eval env select nParents nX pElite nPop term = do
         mwc <- lift create
         let x = \currPop generation -> do
               currPop' <- lift $ sampleFrom mwc $ currPop
               if term currPop' generation
                 then return currPop'
                 else do
-                  let nextPop = stepSteady select nParents nX pElite currPop'
-                  let fBest = fitness $ NE.head $ fst $ bests 1 currPop'
+                  let nextPop = stepSteady eval env select nParents nX pElite currPop'
+                  let fBest = fitness eval $ NE.head $ fst $ bests eval 1 currPop'
                   Pipes.yield (generation, fBest)
                   x nextPop (generation + 1)
-        x pop 0
+        x (population env nPop) 0
 
 
 -- * Selection mechanisms
@@ -289,34 +256,24 @@ chain select1 n pop
 -- Selects @n@ individuals from the population by repeatedly selecting a single
 -- indidual using a tournament of the given size (the same individual can be
 -- selected multiple times, see 'chain').
-tournament :: (Individual i) => N -> Selection RVar i
-tournament nTrnmnt = chain (tournament1 nTrnmnt)
-
-prop_tournament_selectsN :: Individual a => Int -> Int -> NonEmpty a -> Property
-prop_tournament_selectsN nTrnmnt n pop =
-  0 < nTrnmnt
-    && nTrnmnt < length pop
-    && 0 < n
-    ==> monadicIO
-    $ do
-      mwc <- Test.QuickCheck.Monadic.run create
-      pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (tournament 2 n pop)
-      assert $ length pop' == n
+tournament :: (Individual i, Evaluator i e) => e -> N -> Selection RVar i
+tournament eval nTrnmnt = chain (tournament1 eval nTrnmnt)
 
 -- |
 -- Selects one individual from the population using tournament selection.
 tournament1 ::
-  (Individual i) =>
+  (Individual i, Evaluator i e) =>
+  e ->
   -- | Tournament size
   N ->
   Population i ->
   RVar i
-tournament1 nTrnmnt pop
+tournament1 eval nTrnmnt pop
   -- TODO Use Positive for this constraint
   | nTrnmnt <= 0 = undefined
   | otherwise = do
         paricipants <- withoutReplacement nTrnmnt pop
-        return $ NE.head $ fst $ bests 1 paricipants
+        return $ NE.head $ fst $ bests eval 1 paricipants
 
 -- |
 -- Selects @n@ individuals uniformly at random from the population (without
@@ -331,13 +288,6 @@ withoutReplacement n pop
   | n >= length pop = return pop
   | otherwise = fmap (NE.fromList) (shuffleNofM n (length pop) (NE.toList pop))
 
-prop_withoutReplacement_selectsN :: Int -> NonEmpty a -> Property
-prop_withoutReplacement_selectsN n pop =
-  0 < n && n <= length pop ==> monadicIO (do
-    mwc <- Test.QuickCheck.Monadic.run create
-    pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (withoutReplacement n pop)
-    assert $ length pop' == n)
-
 -- * Termination criteria
 
 -- |
@@ -358,13 +308,105 @@ shuffle' :: NonEmpty a -> RVar (NonEmpty a)
 shuffle' xs@(_ :| []) = return xs
 shuffle' xs = fmap (NE.fromList) (shuffle (toList xs))
 
+
+
+instance Pretty Integer where
+  pretty i = "Found int: " <> show i
+
+instance Individual Integer
+
+newtype IntTestEnviroment = IntTestEnviroment ((Integer,Integer),Integer) deriving (Eq) -- IntTestEnviroment ((0,100000),10)
+
+instance Pretty IntTestEnviroment where
+  -- instance Pretty (Maybe Student) where
+  pretty (IntTestEnviroment ((i,j),k)) = "IntTestEnviroment of Individuals between " <> (show i) <> " and "  <> (show j) <> " variance when mutating is " <> (show k)
+
+
+instance Environment Integer IntTestEnviroment where
+
+  new (IntTestEnviroment ((from,to),_)) = uniform from to
+
+  mutate (IntTestEnviroment ((from,to),wiggle)) i = uniform (max from (i - wiggle)) (min to (i + wiggle))
+
+  crossover1 _ i1 i2 = do
+    i1' <- uniform i1 i2
+    i2' <- uniform i1 i2
+    return $ Just (i1',i2')
+
+data NoData = NoData deriving (Eq)
+
+instance Evaluator Integer NoData  where
+
+  fitness _ = fromIntegral . negate
+
+prop_children_asManyAsParents ::
+  N -> NonEmpty Integer -> Property
+prop_children_asManyAsParents nX is =
+  again $
+    monadicIO $
+      do
+        let e = IntTestEnviroment ((0,100000),10)
+        mwc <- Test.QuickCheck.Monadic.run create
+        is' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (children e nX is)
+        return $ counterexample (show is') $ length is' == length is
+
+
+prop_bestsBy_isBestsBy' :: Int -> Population Integer -> Property
+prop_bestsBy_isBestsBy' k pop =
+  k > 0 ==>
+    monadicIO $
+      do
+        let a = fst $ bestsBy k (fitness NoData) pop
+        let b = bestsBy' k (fitness NoData) pop
+        assert $ NE.toList a == b
+
+prop_bestsBy_lengths :: Int -> Population Integer -> Property
+prop_bestsBy_lengths k pop =
+  k > 0 ==> monadicIO $ do
+    let (bests, rest) = bestsBy k (fitness NoData) pop
+    assert $
+      length bests == min k (length pop) && length bests + length rest == length pop
+prop_stepSteady_constantPopSize ::
+  NonEmpty Integer -> Property
+prop_stepSteady_constantPopSize pop =
+  forAll
+    ( (,)
+        <$> choose (1, length pop)
+        <*> choose (1, length pop)
+    )
+    $ \(nParents, nX) -> monadicIO $ do
+      let pElite = 0.1
+      let eval = NoData
+      let env = IntTestEnviroment ((0,100000),10)
+      mwc <- Test.QuickCheck.Monadic.run create
+      pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (stepSteady eval env (tournament eval 4) nParents nX pElite pop)
+      return . counterexample (show pop') $ length pop' == length pop
+
+prop_tournament_selectsN :: Int -> Int -> NonEmpty Integer -> Property
+prop_tournament_selectsN nTrnmnt n pop =
+  0 < nTrnmnt
+    && nTrnmnt < length pop
+    && 0 < n
+    ==> monadicIO
+    $ do
+      mwc <- Test.QuickCheck.Monadic.run create
+      pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (tournament NoData 2 n pop)
+      assert $ length pop' == n
+
+prop_withoutReplacement_selectsN :: Int -> NonEmpty a -> Property
+prop_withoutReplacement_selectsN n pop =
+  0 < n && n <= length pop ==> monadicIO (do
+    mwc <- Test.QuickCheck.Monadic.run create
+    pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (withoutReplacement n pop)
+    assert $ length pop' == n)
+
 prop_shuffle_length :: NonEmpty a -> Property
 prop_shuffle_length xs = monadicIO(do
   mwc <- Test.QuickCheck.Monadic.run create
   xs' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (shuffle' xs)
   assert $ length xs' == length xs)
 
-return []
-
 runTests :: IO Bool
 runTests = $quickCheckAll
+
+return []
diff --git a/src/Main.hs b/src/Main.hs
index 43fbee3..ce53a67 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -48,14 +48,15 @@ main :: IO ()
 main =
   execParser optionsWithHelp >>= \opts -> do
     hSetBuffering stdout NoBuffering
-    let pop = population (populationSize opts) (I prios [])
+    let env = AssignmentEnviroment (students prios, topics prios)
+    let run' = run prios env (tournament prios 2) 2 1 (5 / 100) (populationSize opts) (steps (iterations opts)) :: Producer (Int, R) IO (Population Assignment)
     pop' <-
-      runEffect (for (run (tournament 2) 2 1 (5 / 100) pop (steps (iterations opts))) logCsv)
-    let (res, _) = bests 5 pop'
-    sequence_ $ format <$> res
+      runEffect (for run' logCsv)
+    let (res, _) = bests prios 5 pop'
+    mapM_ format res
   where
     format s = do
-      let f = fitness s
+      let f = fitness prios s
       putErrText $ show f <> "\n" <> pretty s
     logCsv = putText . csv
     csv (t, f) = show t <> " " <> show f
diff --git a/src/Seminar.hs b/src/Seminar.hs
index 4167693..7b85193 100644
--- a/src/Seminar.hs
+++ b/src/Seminar.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 
 module Seminar where
 
@@ -96,47 +97,29 @@ prop_prioOf_singletonNotFound =
 lowestPriority :: Priorities -> Int
 lowestPriority = fromMaybe 0 . maximumMay . fmap snd . join . fmap snd . unP
 
-type Assignment = [(Maybe Student, Maybe Topic)]
+type Assignment = [(Maybe Student, Maybe  Topic)]
 
-data I = I Priorities Assignment
-  deriving (Eq, Show)
+instance Individual Assignment
 
-instance Pretty I where
-  pretty (I p a) =
-    T.unlines (gene <$> a)
-    where
-      gene :: (Maybe Student, Maybe Topic) -> Text
-      gene (s, t) =
-        pretty s <> ": " <> pretty t <> prio s t
-      prio :: Maybe Student -> Maybe Topic -> Text
-      prio s t = " (" <> show (prioOf' p s t) <> ")"
+newtype AssignmentEnviroment = AssignmentEnviroment ([Student],[Topic]) deriving Eq
 
--- |
--- The priority value given by a student to a topic including the case of her not
--- receiving a topic.
-prioOf' :: Priorities -> Maybe Student -> Maybe Topic -> Int
--- TODO Maybe make this neutral?
-prioOf' p Nothing Nothing = lowestPriority p + 2
-prioOf' p (Just s) Nothing = lowestPriority p + 2
-prioOf' p Nothing (Just t) = lowestPriority p + 2
-prioOf' p (Just s) (Just t) = prioOf p s t
+instance Pretty AssignmentEnviroment where
+  pretty (AssignmentEnviroment (persons,assignables)) = "Persons: " <> show persons <> " Assignables: " <> show assignables
 
-instance Individual I where
-  new (I p _) =
-    I p . zip students' <$> shuffle topics'
-    where
-      topics' = (Just <$> topics p) ++ tPadding
-      tPadding = replicate (length (students p) - length (topics p)) Nothing
-      students' = (Just <$> students p) ++ sPadding
-      sPadding = replicate (length (topics p) - length (students p)) Nothing
+instance Environment Assignment AssignmentEnviroment where
+  new (AssignmentEnviroment (persons,assignables)) = do
+    let aPadding = replicate (length persons - length assignables) Nothing
+    let paddedAssignables = (Just <$> assignables) ++ aPadding
+    let pPadding = replicate (length assignables - length persons) Nothing
+    let paddedPersons = (Just <$> persons) ++ pPadding
 
-  fitness (I p a) =
-    negate . sum $ fromIntegral . uncurry (prioOf' p) <$> a
+    mixedAssignables <- shuffle paddedAssignables
+    return $ zip paddedPersons mixedAssignables
 
-  mutate (I p a) = do
-    x <- uniform 0 (length a - 1)
-    y <- uniform 0 (length a - 1)
-    return . I p $ switch x y a
+  mutate _ assignment = do
+    x <- uniform 0 (length assignment - 1)
+    y <- uniform 0 (length assignment - 1)
+    return $ switch x y assignment
 
   -- \|
   --  Borrowed from TSP: Crossover cuts the parents in two and swaps them (if this
@@ -144,31 +127,50 @@ instance Individual I where
   --
   --  TODO Assumes that both individuals are based on the same priorities.
   --
-  crossover1 (I p a1) (I _ a2) = do
-    let l = fromIntegral $ min (length a1) (length a2) :: Double
+  crossover1 e assignment1 assignment2 = do
+    let l = fromIntegral $ min (length assignment1) (length assignment2) :: Double
     x <- uniform 0 l
-    let a1' = zipWith3 (f x) a1 a2 [0 ..]
-    let a2' = zipWith3 (f x) a2 a1 [0 ..]
-    if valid p a1' && valid p a2'
-      then return . Just $ (I p a1', I p a2')
+    let assignment1' = zipWith3 (f x) assignment1 assignment2 [0 ..]
+    let assignment2' = zipWith3 (f x) assignment2 assignment1 [0 ..]
+    if valid e assignment1' && valid e assignment2'
+      then return . Just $ ( assignment1', assignment2')
       else return Nothing
     where
       f x v1 v2 i = if i <= x then v1 else v2
 
+
+instance Pretty Assignment where
+  pretty (a) =
+    T.unlines (gene <$> a)
+    where
+      gene :: (Maybe Student, Maybe Topic) -> Text
+      gene (s, t) =
+        pretty s <> ": " <> pretty t
+
+-- |
+-- The priority value given by a student to a topic including the case of her not
+-- receiving a topic.
+prioOf' :: Priorities -> Maybe Student -> Maybe Topic -> Int
+-- TODO Maybe make this neutral?
+prioOf' p Nothing Nothing = lowestPriority p + 2
+prioOf' p (Just _) Nothing = lowestPriority p + 2
+prioOf' p Nothing (Just _) = lowestPriority p + 2
+prioOf' p (Just s) (Just t) = prioOf p s t
+
+instance Evaluator Assignment Priorities where
+  fitness prio assment =
+    negate . sum $ fromIntegral . uncurry (prioOf' prio) <$> assment
+
 -- |
 -- Swaps topics at positions 'i'' and 'j'' in the given assignment.
 switch :: Int -> Int -> Assignment -> Assignment
 switch i' j' xs
   | 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
+    zipWith (\ind y ->
+    if ind == i' then (fst y, snd (xs !! j'))
+    else if ind == j' then (fst y, snd (xs !! i'))
+    else y) [0..] xs
   | otherwise = xs
 
 -- |
@@ -177,10 +179,10 @@ switch i' j' xs
 -- less topics than students).
 --
 -- Assumes that the priorities are well-formed.
-valid :: Priorities -> Assignment -> Bool
-valid p a =
+valid :: AssignmentEnviroment -> Assignment -> Bool
+valid (AssignmentEnviroment (persons,assignables)) a =
   -- all students must be part of the solution
-  sort (students p) == (catMaybes $ sort studentsAssigned)
+  sort (persons) == (catMaybes $ sort studentsAssigned)
     -- each actual topic (i.e. not “no topic”) is assigned at most once
     && nubOrd (delete Nothing topicsAssigned) == delete Nothing topicsAssigned
   where