Correct package name, add draft for GA module

ga.cabal

@@ -1,5 +1,5 @@
 cabal-version:       2.2
-name:                GA-PFP
+name:                ga
 version:             0.1.0.0
 -- synopsis:
 -- description:

src/GA.hs

@@ -0,0 +1,195 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TupleSections #-}
+
+
+module GA where
+
+
+import Protolude
+
+
+import Control.Arrow hiding (first)
+import qualified Data.List as L
+import Data.List.NonEmpty ((<|))
+import qualified Data.List.NonEmpty as NE
+import Data.Random
+import Data.Random.Distribution.Categorical
+import Data.Random.Sample
+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
+
+
+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 :: (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.
+
+  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 :: (MonadRandom m) => Int -> i -> i -> m (Maybe (i, i))
+  crossover n i1 i2
+    | n <= 0    = return $ Just (i1, i2)
+    | otherwise = do
+        isM <- crossover1 i1 i2
+        maybe (return Nothing) (uncurry (crossover (n - 1))) isM
+
+
+-- 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 }
+  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) >>=
+    sample . fromWeightedList . NE.toList . unPop
+-- TODO Perhaps use stochastic acceptance for performance?
+
+
+{-|
+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)
+proportionate n pop
+  | n > 1 = (<|) <$> proportionate1 pop <*> proportionate (n - 1) pop
+  | otherwise = (:|) <$> proportionate1 pop <*> return []
+
+
+{-|
+Produce offspring circularly.
+-}
+children :: (Individual i, MonadRandom m) => N -> 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')
+
+
+children2 :: (Individual i, MonadRandom m) => N -> i -> i -> m (NonEmpty i)
+children2 nX i1 i2 = do
+  -- TODO Add crossover probability?
+  (i3, i4) <- fromMaybe (i1, i2) <$> crossover nX i1 i2
+  i5 <- mutate i3
+  i6 <- mutate i4
+  return $ i5 :| [i6]
+
+
+{-|
+The @k@ worst individuals in the population.
+-}
+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))) .
+    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
+
+
+worst :: (Individual i, Monad m) => N -> Population i -> m [i]
+worst = flip bestBy (fmap (1 /) . fitness)
+
+
+bests :: (Individual i, Monad m) => N -> Population i -> m [i]
+bests = flip bestBy fitness
+
+
+ga' nParents nX pop term nResult = do
+  pop <- ga nParents nX pop term
+  res <- bests nResult pop
+  sequence $ putText . pretty <$> res
+
+
+ga
+  :: (Individual i, MonadRandom m, Monad m)
+  => 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)
+    ga' nParents nX pop term t = do
+      -- trace (show t <> ": " <> show (length pop)) $ return ()
+      is <- proportionate nParents pop
+      i :| is' <- children nX is
+      -- traceShow (length is') $ return ()
+      iWorsts <- worst nParents pop
+      -- traceShow (length iWorsts) $ return ()
+      -- for the fromList to not fail, n < length pop
+      -- replace the worst ones
+      let pop' = Pop $ i :| is' <> foldr L.delete (NE.toList . unPop $ pop) iWorsts
+      -- replace fitness proportionally
+      -- let pop' = Pop <$> proportionate (length pop) (pop <> Pop is')
+      if term pop' t
+        then
+          return pop'
+        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.
+-}
+steps :: N -> Termination i
+steps tEnd _ t = t >= tEnd