Cleanup existing GA code

src/GA.hs

@@ -1,17 +1,18 @@
-{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TupleSections #-}
 
-
 module GA where
 
-
+-- NEXT commit everything
-import Protolude
+-- TODO add factory floor optimizer:
-
+-- [2019-07-15] GA that optimizes factory floor
-
+--   - data: graph of workstations with edge weights being the number of walks between them
+--   - desired: optimal configuration that reduces crossings
+--   - space: 15 workstations that can be positioned in a 20 x 20 space
 import Control.Arrow hiding (first)
 import qualified Data.List as L
 import Data.List.NonEmpty ((<|))
@@ -19,20 +20,25 @@ import qualified Data.List.NonEmpty as NE
 import Data.Random
 import Data.Random.Distribution.Categorical
 import Data.Random.Sample
+import Pretty
+import Protolude
 import Test.QuickCheck hiding (sample, shuffle)
 import Test.QuickCheck.Instances
 import Test.QuickCheck.Monadic
 
-
-import Pretty
-
-
 -- TODO Enforce this being > 0
 type N = Int
-type R = Float
 
+type R = Double
 
+-- alternative could be
+-- data I a
+--   = I
+--       { mutate :: m (I a),
+--         crossover1 :: (MonadRandom m) => I a -> m (Maybe (I a, I a))
+--       }
 class Eq i => Individual i where
+
   {-|
   Generates a completely random individual given an existing individual.
   
@@ -42,16 +48,21 @@ class Eq i => Individual i where
   be done nicer!
   -}
   new :: (MonadRandom m) => i -> m i
+
   {-|
   Generates a random population of the given size.
   -}
   population :: (MonadRandom m) => N -> i -> m (Population i)
   population 0 _ = undefined
   population n i = Pop . NE.fromList <$> replicateM n (new i)
+
   mutate :: (MonadRandom m) => i -> m i
+
   crossover1 :: (MonadRandom m) => i -> i -> m (Maybe (i, i))
+
   -- TODO Perhaps rather add a 'features' function (and parametrize select1 etc. with fitness function)?
   fitness :: (Monad m) => i -> m R
+
   {-|
   Performs an n-point crossover.
   
@@ -66,31 +77,28 @@ class Eq i => Individual i where
       isM <- crossover1 i1 i2
       maybe (return Nothing) (uncurry (crossover (n - 1))) isM
 
-
+-- TODO Perhaps use Data.Vector.Sized for the population?
--- TODO Do i want to model the population using Data.Vector.Sized?
 {-|
 It would be nice to model populations as GADTs but then no functor instance were
 possible:
 > data Population a where
 >  Pop :: Individual a => NonEmpty a -> Population a
 -}
-newtype Population a = Pop { unPop :: NonEmpty a }
+newtype Population a = Pop {unPop :: NonEmpty a}
   deriving (Foldable, Functor, Semigroup, Show, Traversable)
 
-
 instance (Arbitrary i) => Arbitrary (Population i) where
   arbitrary = Pop <$> arbitrary
 
-
 {-|
 Selects one individual from the population using proportionate selection.
 -}
 proportionate1 :: (Individual i, MonadRandom m) => Population i -> m i
 proportionate1 pop =
-  sequence ((\ i -> (, i) <$> fitness i) <$> pop) >>=
+  sequence ((\i -> (,i) <$> fitness i) <$> pop)
-    sample . fromWeightedList . NE.toList . unPop
+    >>= sample . fromWeightedList . NE.toList . unPop
--- TODO Perhaps use stochastic acceptance for performance?
 
+-- TODO Perhaps use stochastic acceptance for performance?
 
 {-|
 Selects @n@ individuals from the population using proportionate selection.
@@ -98,12 +106,13 @@ Selects @n@ individuals from the population using proportionate selection.
 -- TODO Perhaps use Data.Vector.Sized for the result?
 proportionate
   :: (Individual i, MonadRandom m)
-  => N -> Population i -> m (NonEmpty i)
+  => N
+  -> Population i
+  -> m (NonEmpty i)
 proportionate n pop
   | n > 1 = (<|) <$> proportionate1 pop <*> proportionate (n - 1) pop
   | otherwise = (:|) <$> proportionate1 pop <*> return []
 
-
 {-|
 Produce offspring circularly.
 -}
@@ -113,7 +122,6 @@ children nX (i1 :| [i2]) = children2 nX i1 i2
 children nX (i1 :| i2 : is') =
   (<>) <$> children2 nX i1 i2 <*> children nX (NE.fromList is')
 
-
 children2 :: (Individual i, MonadRandom m) => N -> i -> i -> m (NonEmpty i)
 children2 nX i1 i2 = do
   -- TODO Add crossover probability?
@@ -122,43 +130,63 @@ children2 nX i1 i2 = do
   i6 <- mutate i4
   return $ i5 :| [i6]
 
-
 {-|
-The @k@ worst individuals in the population.
+The @k@ best individuals in the population when comparing using the supplied
+function.
 -}
 bestBy :: (Individual i, Monad m) => N -> (i -> m R) -> Population i -> m [i]
 bestBy k f =
-  fmap (NE.take k . fmap fst . NE.sortBy (comparing (Down . snd))) .
+  fmap (NE.take k . fmap fst . NE.sortBy (comparing (Down . snd)))
-    traverse (\ i -> (i, ) <$> f i) . unPop
+    . traverse (\i -> (i,) <$> f i)
-
+    . unPop
 
 -- TODO no trivial instance for worst
 -- prop_worstLength :: Int -> Population Int -> Property
 -- prop_worstLength k pop = monadicIO $ (k ==) . length <$> worst k pop
-
+{-|
-
+The @k@ worst individuals in the population.
+-}
 worst :: (Individual i, Monad m) => N -> Population i -> m [i]
 worst = flip bestBy (fmap (1 /) . fitness)
 
-
+{-|
+The @k@ best individuals in the population.
+-}
 bests :: (Individual i, Monad m) => N -> Population i -> m [i]
 bests = flip bestBy fitness
 
-
+{-|
+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
 
+{-|
+Runs the GA, using in each iteration
+ - @nParents@ parents for creating @nParents@ children and
+ - @nX@-point crossover.
 
+It terminates after the termination criterion is fulfilled.
+-}
 ga
   :: (Individual i, MonadRandom m, Monad m)
-  => N -> N -> Population i -> Termination i -> m (Population i)
+  => N
+  -> N
+  -> Population i
+  -> Termination i
+  -> m (Population i)
 ga nParents nX pop term = ga' nParents nX pop term 0
   where
     ga'
       :: (Individual i, MonadRandom m, Monad m)
-      => N -> N -> Population i -> Termination i -> N -> m (Population i)
+      => N
+      -> N
+      -> Population i
+      -> Termination i
+      -> N
+      -> m (Population i)
     ga' nParents nX pop term t = do
       -- trace (show t <> ": " <> show (length pop)) $ return ()
       is <- proportionate nParents pop
@@ -172,22 +200,17 @@ ga nParents nX pop term = ga' nParents nX pop term 0
       -- replace fitness proportionally
       -- let pop' = Pop <$> proportionate (length pop) (pop <> Pop is')
       if term pop' t
-        then
+        then return pop'
-          return pop'
+        else ga' nParents nX pop' term (t + 1)
-        else
-          ga' nParents nX pop' term (t + 1)
-
 
 -- * Termination criteria
 
-
 {-|
 Termination decisions may take into account the current population and the
 current iteration number.
 -}
 type Termination i = Population i -> N -> Bool
 
-
 {-|
 Termination after a number of steps.
 -}