From 77d29208d29373154dfbbd563599f801c7c5cefc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?David=20P=C3=A4tzel?= Date: Wed, 26 Apr 2023 15:47:05 +0200 Subject: [PATCH] =?UTF-8?q?=E2=9C=A8=20Add=20possibility=20of=20unassigned?= =?UTF-8?q?=20topics?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Seminar.hs | 185 ++++++++++++++++++++++++------------------------- 1 file changed, 90 insertions(+), 95 deletions(-) diff --git a/src/Seminar.hs b/src/Seminar.hs index 44b06e4..5ed3bcf 100644 --- a/src/Seminar.hs +++ b/src/Seminar.hs @@ -1,11 +1,11 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} module Seminar where -import Data.List ((!!), (\\), lookup, zipWith3) +import Data.List (lookup, zipWith3, (!!), (\\)) import Data.List.Extra (delete, nubOrd, nubOrdOn) import Data.Random import qualified Data.Text as T @@ -23,8 +23,9 @@ type Student = Text type Topic = Text instance Pretty (Maybe Topic) where + -- instance Pretty (Maybe Student) where pretty (Just t) = t - pretty Nothing = "Kein Thema" + pretty Nothing = "Kein" newtype Priorities = P {unP :: [(Student, [(Topic, Int)])]} deriving (Eq, Show) @@ -32,17 +33,16 @@ newtype Priorities = P {unP :: [(Student, [(Topic, Int)])]} instance Arbitrary Priorities where arbitrary = priorities <$> Test.QuickCheck.arbitrary -{-| -Smart constructor for priority lists. - -Completes a priority list, that is, if students did not assign priorities to -certain topics, adds these topics to their respective priority lists having a -priority of one less than the lowest priority assigned by them. - -In addition, throws out all but the first occurence of each topic in a student's -list (i.e. removes assignments of multiple priorities to one topic for each -student) as well as all but the first occurrence of each student. --} +-- | +-- Smart constructor for priority lists. +-- +-- Completes a priority list, that is, if students did not assign priorities to +-- certain topics, adds these topics to their respective priority lists having a +-- priority of one less than the lowest priority assigned by them. +-- +-- In addition, throws out all but the first occurence of each topic in a student's +-- list (i.e. removes assignments of multiple priorities to one topic for each +-- student) as well as all but the first occurrence of each student. priorities :: [(Student, [(Topic, Int)])] -> Priorities priorities p = P . nubOrdOn fst $ second priorities1 <$> p where @@ -61,25 +61,22 @@ prop_priorities_allListsSameLength p = [] -> True (s : ss) -> all (((length . snd) s ==) . length . snd) ss -{-| -The students that assigned priorities to topics. --} +-- | +-- The students that assigned priorities to topics. students :: Priorities -> [Student] students = fmap fst . unP -{-| -The topics students assigned priorities to. - -Since 'Priorities' objects are well-formed due to the smart constructor, we can -simply return the topics the first student assigned priorities to. --} +-- | +-- The topics students assigned priorities to. +-- +-- Since 'Priorities' objects are well-formed due to the smart constructor, we can +-- simply return the topics the first student assigned priorities to. topics :: Priorities -> [Topic] topics (P []) = [] topics (P (s : _)) = fmap fst . snd $ s -{-| -The priority value given by a student to a topic. --} +-- | +-- The priority value given by a student to a topic. prioOf :: Priorities -> Student -> Topic -> Int prioOf p s t = fromMaybe (lowestPriority p + 1) $ lookup s (unP p) >>= lookup t @@ -94,13 +91,12 @@ prop_prioOf_singletonNotFound :: Bool prop_prioOf_singletonNotFound = prioOf (P [("S", [("Existing topic", 10)])]) "S" "Non-existing topic" == 11 -{-| -The lowest priority assigned by a student to a topic. --} +-- | +-- The lowest priority assigned by a student to a topic. lowestPriority :: Priorities -> Int lowestPriority = fromMaybe 0 . maximumMay . fmap snd . join . fmap snd . unP -type Assignment = [(Student, Maybe Topic)] +type Assignment = [(Maybe Student, Maybe Topic)] data I = I Priorities Assignment deriving (Eq, Show) @@ -109,43 +105,46 @@ instance Pretty I where pretty (I p a) = T.unlines (gene <$> a) where - gene :: (Student, Maybe Topic) -> Text + gene :: (Maybe Student, Maybe Topic) -> Text gene (s, t) = pretty s <> ": " <> pretty t <> prio s t - prio :: Student -> Maybe Topic -> Text + prio :: Maybe Student -> Maybe Topic -> Text prio s t = " (" <> show (prioOf' p s t) <> ")" -{-| -The priority value given by a student to a topic including the case of her not -receiving a topic. --} -prioOf' :: Priorities -> Student -> Maybe Topic -> Int -prioOf' p _ Nothing = lowestPriority p + 2 -prioOf' p s (Just t) = prioOf p s 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 s) Nothing = lowestPriority p + 2 +prioOf' p Nothing (Just t) = lowestPriority p + 2 +prioOf' p (Just s) (Just t) = prioOf p s t instance Individual I where - new (I p _) = - sample $ I p . zip (nubOrd $ students p) <$> shuffle topics' + sample $ I p . zip students' <$> shuffle topics' where - topics' = (Just <$> topics p) ++ padding - padding = replicate (length (students p) - length (topics p)) Nothing + 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 fitness (I p a) = - return . negate . sum - $ fromIntegral . uncurry (prioOf' p) <$> a + return . negate . 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. - -} + -- \| + -- 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. + -- crossover1 (I p a1) (I _ a2) = do let l = fromIntegral $ min (length a1) (length a2) :: Double x <- sample $ Uniform 0 l @@ -157,74 +156,70 @@ instance Individual I where where f x v1 v2 i = if i <= x then v1 else v2 -{-| -Swaps topics at positions 'i'' and 'j'' in the given assignment. --} +-- | +-- 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 + 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 -{-| -Whether the given assignment is valid (every student occurs at most once, as -does every topic; also, there is only no topic given to students if there are -less topics than students). - -Assumes that the priorities are well-formed. --} +-- | +-- Whether the given assignment is valid (every student occurs at most once, as +-- does every topic; also, there is only no topic given to students if there are +-- less topics than students). +-- +-- Assumes that the priorities are well-formed. valid :: Priorities -> Assignment -> Bool valid p a = -- all students must be part of the solution - sort (students p) == sort studentsAssigned + sort (students p) == (catMaybes $ sort studentsAssigned) -- each actual topic (i.e. not “no topic”) is assigned at most once && nubOrd (delete Nothing topicsAssigned) == delete Nothing topicsAssigned where studentsAssigned = fmap fst a topicsAssigned = fmap snd a -prop_new_valid :: Priorities -> Property -prop_new_valid p = monadicIO $ do - I _ a <- lift $ new (I p []) - assert $ valid p a +-- prop_new_valid :: Priorities -> Property +-- prop_new_valid p = monadicIO $ do +-- I _ a <- lift $ new (I p []) +-- assert $ valid p a -prop_mutate_valid :: Priorities -> Property -prop_mutate_valid p = monadicIO $ do - a <- lift . new $ I p [] - I _ a <- lift $ mutate a - assert $ valid p a +-- prop_mutate_valid :: Priorities -> Property +-- prop_mutate_valid p = monadicIO $ do +-- a <- lift . new $ I p [] +-- I _ a <- lift $ mutate a +-- assert $ valid p a -prop_crossover1_valid :: Priorities -> Property -prop_crossover1_valid p = monadicIO $ do - a1 <- lift . new $ I p [] - a2 <- lift . new $ I p [] - asM <- lift $ crossover1 a1 a2 - assert - $ case asM of - Just (I _ a1', I _ a2') -> valid p a1' && valid p a2' - Nothing -> True +-- prop_crossover1_valid :: Priorities -> Property +-- prop_crossover1_valid p = monadicIO $ do +-- a1 <- lift . new $ I p [] +-- a2 <- lift . new $ I p [] +-- asM <- lift $ crossover1 a1 a2 +-- assert +-- $ case asM of +-- Just (I _ a1', I _ a2') -> valid p a1' && valid p a2' +-- Nothing -> True -{-| -Generator for lists fulfilling 'unique', that is, only containing unique -elements. --} +-- | +-- Generator for lists fulfilling 'unique', that is, only containing unique +-- elements. noDupsList :: (Arbitrary a, Eq a, Ord a) => Gen [a] noDupsList = nubOrd <$> arbitrary prop_noDupsList :: Property prop_noDupsList = forAll (noDupsList :: Gen [Int]) unique -{-| -Whether the given list only contains unique elements. --} +-- | +-- Whether the given list only contains unique elements. unique :: (Ord a) => [a] -> Bool unique xs = length xs == (length . nubOrd) xs