🎨 Reformat modules with new ormolu defaults

src/GA.hs

@@ -2,25 +2,24 @@
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
-{-|
+-- |
-Module      : GA
+-- Module      : GA
-Description : Abstract genetic algorithm
+-- Description : Abstract genetic algorithm
-Copyright   : David Pätzel, 2019
+-- Copyright   : David Pätzel, 2019
-License     : GPL-3
+-- License     : GPL-3
-Maintainer  : David Pätzel <david.paetzel@posteo.de>
+-- Maintainer  : David Pätzel <david.paetzel@posteo.de>
-Stability   : experimental
+-- Stability   : experimental
-
+--
-Simplistic abstract definition of a genetic algorithm.
+-- Simplistic abstract definition of a genetic algorithm.
-
+--
-In order to use it for a certain problem, basically, you have to make your
+-- In order to use it for a certain problem, basically, you have to make your
-solution type an instance of 'Individual' and then simply call the 'run'
+-- solution type an instance of 'Individual' and then simply call the 'run'
-function.
+-- function.
--}
 module GA where
 
 import Control.Arrow hiding (first, second)
@@ -42,19 +41,17 @@ 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.
 
-  {-|
-  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 :: (MonadRandom m) => i -> m i
 
-  {-|
+  -- |
-  Generates a random population of the given size.
+  --  Generates a random population of the given size.
-  -}
   population :: (MonadRandom m) => N -> i -> m (Population i)
   population n i
     | n <= 0 = undefined
@@ -64,34 +61,30 @@ class Eq i => Individual i where
 
   crossover1 :: (MonadRandom m) => i -> i -> m (Maybe (i, i))
 
-  {-|
+  -- |
-  An individual's fitness. Higher values are considered “better”.
+  --  An individual's fitness. Higher values are considered “better”.
-  
+  --
-  We explicitely allow fitness values to be have any sign (see, for example,
+  --  We explicitely allow fitness values to be have any sign (see, for example,
-  'proportionate1').
+  --  'proportionate1').
-  -}
   fitness :: (Monad m) => i -> m R
 
-  {-|
+  -- |
-  Performs an n-point crossover.
+  --  Performs an n-point crossover.
-  
+  --
-  Given the function for single-point crossover, 'crossover1', this function can
+  --  Given the function for single-point crossover, 'crossover1', this function can
-  be derived through recursion and a monad combinator (which is also the default
+  --  be derived through recursion and a monad combinator (which is also the default
-  implementation).
+  --  implementation).
-  -}
   crossover :: (MonadRandom m) => N -> i -> i -> m (Maybe (i, i))
   crossover n i1 i2
     | n <= 0 = return $ Just (i1, i2)
     | otherwise = do
-      isM <- crossover1 i1 i2
+        isM <- crossover1 i1 i2
-      maybe (return Nothing) (uncurry (crossover (n - 1))) isM
+        maybe (return Nothing) (uncurry (crossover (n - 1))) isM
 
-{-|
+-- |
-Needed for QuickCheck tests, for now, a very simplistic implementation should
+-- Needed for QuickCheck tests, for now, a very simplistic implementation should
-suffice.
+-- suffice.
--}
 instance Individual Integer where
-
   new _ = sample $ uniform 0 (0 + 100000)
 
   mutate i = sample $ uniform (i - 10) (i + 10)
@@ -100,32 +93,31 @@ instance Individual Integer where
 
   fitness = return . fromIntegral . negate
 
-{-|
+-- |
-Populations are just basic non-empty lists.
+-- Populations are just basic non-empty lists.
--}
 type Population i = NonEmpty i
 
-{-|
+-- |
-Produces offspring circularly from the given list of parents.
+-- Produces offspring circularly from the given list of parents.
--}
+children ::
-children
+  (Individual i, MonadRandom m) =>
-  :: (Individual i, MonadRandom m)
+  -- | The @nX@ of the @nX@-point crossover operator
-  => N -- ^ The @nX@ of the @nX@-point crossover operator
+  N ->
-  -> NonEmpty i
+  NonEmpty i ->
-  -> m (NonEmpty i)
+  m (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')
 
-prop_children_asManyAsParents
+prop_children_asManyAsParents ::
-  :: (Individual a, Show a) => N -> NonEmpty a -> Property
+  (Individual a, Show a) => N -> NonEmpty a -> Property
 prop_children_asManyAsParents nX is =
-  again
+  again $
-    $ monadicIO
+    monadicIO $
-    $ do
+      do
-      is' <- lift $ children nX is
+        is' <- lift $ children nX is
-      return $ counterexample (show is') $ length is' == length is
+        return $ counterexample (show is') $ length is' == length is
 
 children2 :: (Individual i, MonadRandom m) => N -> i -> i -> m (NonEmpty i)
 children2 nX i1 i2 = do
@@ -135,18 +127,17 @@ children2 nX i1 i2 = do
   i6 <- mutate i4
   return $ i5 :| [i6]
 
-{-|
+-- |
-The best according to a function; returns up to @k@ results and the remaining
+-- The best according to a function; returns up to @k@ results and the remaining
-population.
+-- population.
-
+--
-If @k <= 0@, this returns the best one anyway (as if @k == 1@).
+-- If @k <= 0@, this returns the best one anyway (as if @k == 1@).
--}
+bestsBy ::
-bestsBy
+  (Individual i, Monad m) =>
-  :: (Individual i, Monad m)
+  N ->
-  => N
+  (i -> m R) ->
-  -> (i -> m R)
+  Population i ->
-  -> Population i
+  m (NonEmpty i, [i])
-  -> m (NonEmpty i, [i])
 bestsBy k f pop@(i :| pop')
   | k <= 0 = bestsBy 1 f pop
   | otherwise = foldM run (i :| [], []) pop'
@@ -157,10 +148,9 @@ bestsBy k f pop@(i :| pop')
     sorted =
       fmap (fmap fst . NE.sortOn (Down . snd)) . traverse (\i -> (i,) <$> f i)
 
-{-|
+-- |
-The @k@ best individuals in the population when comparing using the supplied
+-- The @k@ best individuals in the population when comparing using the supplied
-function.
+-- function.
--}
 bestsBy' :: (Individual i, Monad m) => N -> (i -> m R) -> Population i -> m [i]
 bestsBy' k f =
   fmap (NE.take k . fmap fst . NE.sortBy (comparing (Down . snd)))
@@ -168,48 +158,50 @@ bestsBy' k f =
 
 prop_bestsBy_isBestsBy' :: Individual a => Int -> Population a -> Property
 prop_bestsBy_isBestsBy' k pop =
-  k > 0
+  k > 0 ==>
-    ==> monadicIO
+    monadicIO $
-    $ do
+      do
-      a <- fst <$> bestsBy k fitness pop
+        a <- fst <$> bestsBy k fitness pop
-      b <- bestsBy' k fitness pop
+        b <- bestsBy' k fitness pop
-      assert $ NE.toList a == b
+        assert $ NE.toList a == b
 
 prop_bestsBy_lengths :: Individual a => Int -> Population a -> Property
 prop_bestsBy_lengths k pop =
   k > 0 ==> monadicIO $ do
     (bests, rest) <- bestsBy k fitness pop
-    assert
+    assert $
-      $ length bests == min k (length pop) && length bests + length rest == length pop
+      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).
+-- The @k@ worst individuals in the population (and the rest of the population).
--}
 worst :: (Individual i, Monad m) => N -> Population i -> m (NonEmpty i, [i])
 worst = flip bestsBy (fmap negate . fitness)
 
-{-|
+-- |
-The @k@ best individuals in the population (and the rest of the population).
+-- The @k@ best individuals in the population (and the rest of the population).
--}
 bests :: (Individual i, Monad m) => N -> Population i -> m (NonEmpty i, [i])
 bests = flip bestsBy fitness
 
 -- TODO add top x percent parent selection (select n guys, sort by fitness first)
-{-|
+
-Performs one iteration of a steady state genetic algorithm that in each
+-- |
-iteration that creates @k@ offspring simply deletes the worst @k@ individuals
+-- Performs one iteration of a steady state genetic algorithm that in each
-while making sure that the given percentage of elitists survive (at least 1
+-- iteration that creates @k@ offspring simply deletes the worst @k@ individuals
-elitist, even if the percentage is 0 or low enough for rounding to result in 0
+-- while making sure that the given percentage of elitists survive (at least 1
-elitists).
+-- elitist, even if the percentage is 0 or low enough for rounding to result in 0
--}
+-- elitists).
-stepSteady
+stepSteady ::
-  :: (Individual i, MonadRandom m, Monad m)
+  (Individual i, MonadRandom m, Monad m) =>
-  => Selection m i -- ^ Mechanism for selecting parents
+  -- | Mechanism for selecting parents
-  -> N -- ^ Number of parents @nParents@ for creating @nParents@ children
+  Selection m i ->
-  -> N -- ^ How many crossover points (the @nX@ in @nX@-point crossover)
+  -- | Number of parents @nParents@ for creating @nParents@ children
-  -> R -- ^ Elitism ratio @pElite@
+  N ->
-  -> Population i
+  -- | How many crossover points (the @nX@ in @nX@-point crossover)
-  -> m (Population i)
+  N ->
+  -- | Elitism ratio @pElite@
+  R ->
+  Population i ->
+  m (Population i)
 stepSteady select nParents nX pElite pop = do
   -- TODO Consider keeping the fitness evaluations already done for pop (so we
   -- only reevaluate iChildren)
@@ -226,12 +218,13 @@ stepSteady select nParents nX pElite pop = do
         then return elitists
         else
           (elitists <>)
-            . fst <$> bests (length pop - length elitists) (i :| is)
+            . fst
+            <$> bests (length pop - length elitists) (i :| is)
   where
     nBest = floor . (pElite *) . fromIntegral $ NE.length pop
 
-prop_stepSteady_constantPopSize
+prop_stepSteady_constantPopSize ::
-  :: (Individual a, Show a) => NonEmpty a -> Property
+  (Individual a, Show a) => NonEmpty a -> Property
 prop_stepSteady_constantPopSize pop =
   forAll
     ( (,)
@@ -243,82 +236,83 @@ prop_stepSteady_constantPopSize pop =
       pop' <- lift $ stepSteady (tournament 4) nParents nX pElite pop
       return . counterexample (show pop') $ length pop' == length pop
 
-{-|
+-- |
-Given an initial population, runs the GA until the termination criterion is
+-- Given an initial population, runs the GA until the termination criterion is
-fulfilled.
+-- fulfilled.
-
+--
-Uses the pipes library to, in each step, 'Pipes.yield' the currently best known
+-- Uses the pipes library to, in each step, 'Pipes.yield' the currently best known
-solution.
+-- solution.
--}
+run ::
-run
+  (Individual i, Monad m, MonadRandom m) =>
-  :: (Individual i, Monad m, MonadRandom m)
+  -- | Mechanism for selecting parents
-  => Selection m i -- ^ Mechanism for selecting parents
+  Selection m i ->
-  -> N -- ^ Number of parents @nParents@ for creating @nParents@ children
+  -- | Number of parents @nParents@ for creating @nParents@ children
-  -> N -- ^ How many crossover points (the @nX@ in @nX@-point crossover)
+  N ->
-  -> R -- ^ Elitism ratio @pElite@
+  -- | How many crossover points (the @nX@ in @nX@-point crossover)
-  -> Population i
+  N ->
-  -> Termination i
+  -- | Elitism ratio @pElite@
-  -> Producer (Int, R) m (Population i)
+  R ->
+  Population i ->
+  Termination i ->
+  Producer (Int, R) m (Population i)
 run select nParents nX pElite pop term = step' 0 pop
   where
     step' t pop
       | term pop t = return pop
       | otherwise = do
-        pop' <- lift $ stepSteady select nParents nX pElite pop
+          pop' <- lift $ stepSteady select nParents nX pElite pop
-        (iBests, _) <- lift $ bests 1 pop'
+          (iBests, _) <- lift $ bests 1 pop'
-        fs <- lift . sequence $ fitness <$> iBests
+          fs <- lift . sequence $ fitness <$> iBests
-        let fBest = NE.head fs
+          let fBest = NE.head fs
-        yield (t, fBest)
+          Pipes.yield (t, fBest)
-        step' (t + 1) pop'
+          step' (t + 1) pop'
 
 -- * Selection mechanisms
 
-{-|
+-- |
-A function generating a monadic action which selects a given number of
+-- A function generating a monadic action which selects a given number of
-individuals from the given population.
+-- individuals from the given population.
--}
 type Selection m i = N -> Population i -> m (NonEmpty i)
 
-{-|
+-- |
-Selects @n@ individuals from the population the given mechanism by repeatedly
+-- Selects @n@ individuals from the population the given mechanism by repeatedly
-selecting a single individual using the given selection mechanism (with
+-- selecting a single individual using the given selection mechanism (with
-replacement, so the same individual can be selected multiple times).
+-- replacement, so the same individual can be selected multiple times).
--}
+chain ::
-chain
+  (Individual i, MonadRandom m) =>
-  :: (Individual i, MonadRandom m)
+  (Population i -> m i) ->
-  => (Population i -> m i)
+  Selection m i
-  -> Selection m i
 -- TODO Ensure that the same individual is not selected multiple times
 -- (require Selections to partition)
 chain select1 n pop
   | n > 1 = (<|) <$> select1 pop <*> chain select1 (n - 1) pop
   | otherwise = (:|) <$> select1 pop <*> return []
 
-{-|
+-- |
-Selects @n@ individuals from the population by repeatedly selecting a single
+-- Selects @n@ individuals from the population by repeatedly selecting a single
-indidual using a tournament of the given size (the same individual can be
+-- indidual using a tournament of the given size (the same individual can be
-selected multiple times, see 'chain').
+-- selected multiple times, see 'chain').
--}
 tournament :: (Individual i, MonadRandom m) => N -> Selection m 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 < nTrnmnt
-    && 0 < n ==> monadicIO
+    && nTrnmnt < length pop
+    && 0 < n
+    ==> monadicIO
     $ do
       pop' <- lift $ tournament 2 n pop
       assert $ length pop' == n
 
-{-|
+-- |
-Selects one individual from the population using tournament selection.
+-- Selects one individual from the population using tournament selection.
--}
+tournament1 ::
-tournament1
+  (Individual i, MonadRandom m) =>
-  :: (Individual i, MonadRandom m)
+  -- | Tournament size
-  => N
+  N ->
-  -- ^ Tournament size
+  Population i ->
-  -> Population i
+  m i
-  -> m i
 tournament1 nTrnmnt pop
   -- TODO Use Positive for this constraint
   | nTrnmnt <= 0 = undefined
@@ -326,21 +320,20 @@ tournament1 nTrnmnt pop
   where
     trnmnt = withoutReplacement nTrnmnt pop
 
-{-|
+-- |
-Selects @n@ individuals uniformly at random from the population (without
+-- Selects @n@ individuals uniformly at random from the population (without
-replacement, so if @n >= length pop@, simply returns @pop@).
+-- replacement, so if @n >= length pop@, simply returns @pop@).
--}
+withoutReplacement ::
-withoutReplacement
+  (MonadRandom m) =>
-  :: (MonadRandom m)
+  -- | How many individuals to select
-  => N
+  N ->
-  -- ^ How many individuals to select
+  Population i ->
-  -> Population i
+  m (NonEmpty i)
-  -> m (NonEmpty i)
 withoutReplacement 0 _ = undefined
 withoutReplacement n pop
   | n >= length pop = return pop
   | otherwise =
-    fmap NE.fromList . sample . shuffleNofM n (length pop) $ NE.toList pop
+      fmap NE.fromList . sample . shuffleNofM n (length pop) $ NE.toList pop
 
 prop_withoutReplacement_selectsN :: Int -> NonEmpty a -> Property
 prop_withoutReplacement_selectsN n pop =
@@ -350,23 +343,20 @@ prop_withoutReplacement_selectsN n pop =
 
 -- * Termination criteria
 
-{-|
+-- |
-Termination decisions may take into account the current population and the
+-- Termination decisions may take into account the current population and the
-current iteration number.
+-- current iteration number.
--}
 type Termination i = Population i -> N -> Bool
 
-{-|
+-- |
-Termination after a number of steps.
+-- Termination after a number of steps.
--}
 steps :: N -> Termination i
 steps tEnd _ t = t >= tEnd
 
 -- * Helper functions
 
-{-|
+-- |
-Shuffles a non-empty list.
+-- Shuffles a non-empty list.
--}
 shuffle' :: (MonadRandom m) => NonEmpty a -> m (NonEmpty a)
 shuffle' xs@(_ :| []) = return xs
 shuffle' xs = do

src/Main.hs

@@ -1,55 +1,59 @@
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
 import Options.Applicative
 import Pipes
 import Pretty
 import Protolude hiding (for, option)
 import System.IO
-import Szenario191
+-- import Szenario212Pun
+import Szenario222
 
-data Options
+data Options = Options
-  = Options
+  { iterations :: N,
-      { iterations :: N,
+    populationSize :: N
-        populationSize :: N
+  }
-      }
 
 options :: Parser Options
 options =
   Options
-    <$> option auto
+    <$> option
-          ( long "iterations"
+      auto
-              <> short 'i'
+      ( long "iterations"
-              <> metavar "N"
+          <> short 'i'
-              <> value 1000
+          <> metavar "N"
-              <> help "Number of iterations"
+          <> value 1000
-          )
+          <> help "Number of iterations"
-    <*> option auto
+      )
-          ( long "population-size"
+    <*> option
-              <> short 'p'
+      auto
-              <> metavar "N"
+      ( long "population-size"
-              <> value 100
+          <> short 'p'
-              <> help "Population size"
+          <> metavar "N"
-          )
+          <> value 100
+          <> help "Population size"
+      )
 
 optionsWithHelp :: ParserInfo Options
 optionsWithHelp =
-  info (helper <*> options)
+  info
+    (helper <*> options)
     ( fullDesc
         <> progDesc "Run a GA"
         <> header "haga - Haskell implementations of EAs"
     )
 
 main :: IO ()
-main = execParser optionsWithHelp >>= \opts -> do
+main =
-  hSetBuffering stdout NoBuffering
+  execParser optionsWithHelp >>= \opts -> do
-  pop <- population (populationSize opts) (I prios [])
+    hSetBuffering stdout NoBuffering
-  pop' <-
+    pop <- population (populationSize opts) (I prios [])
-    runEffect
+    pop' <-
-      $ for (run (tournament 2) 2 1 (5 / 100) pop (steps $ iterations opts)) log
+      runEffect $
-  (res, _) <- bests 5 pop'
+        for (run (tournament 2) 2 1 (5 / 100) pop (steps $ iterations opts)) log
-  sequence_ $ format <$> res
+    (res, _) <- bests 5 pop'
+    sequence_ $ format <$> res
   where
     format s = do
       f <- liftIO $ fitness s

src/Szenario191.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
 module Szenario191
   ( module Seminar,