I have implemented two genetic operators, which is really just a fancy way of mangling lists. In particular OX-1 (illustration) and displacement mutation.

I found it necessary to extract out the randomness from the algorithms in order to do unit testing with some known examples. Is that a decent way to go about it? Any comments on performance, structure, clarify and so forth is appreciated.

import           Control.Monad.Random
import qualified Data.Vector.Generic  as V

-- | Displacement Mutation:
-- A continous part of random length is taken out from a random position
-- and reinserted at a random position
displaceMutation :: (MonadRandom m, V.Vector v a) => v a -> m (v a)
displaceMutation genome = do
  let len = V.length genome
  idxs@(l, r) <- randIndices len
  insert_pos <- getRandomR (0, len-(r-l))
  return $ displaceMutationStat idxs insert_pos genome

-- | Displacement mutation with chosen 'slice indexes' and 'insert position'
displaceMutationStat :: (V.Vector v a) => (Int, Int) -> Int -> v a -> v a
displaceMutationStat (left, right) insert_pos genome = mutated
  n = right - left
  part = V.slice left n genome -- O(1)
  leftovers = V.take left genome V.++ V.drop right genome -- O(m+n)
  mutated = V.take insert_pos leftovers V.++ part V.++ V.drop insert_pos leftovers -- O(m+n)

-- | Ordered crossover (OX-1) between two individuals
orderedCrossover :: (Eq a, MonadRandom m, V.Vector v a) => v a -> v a -> m (v a, v a)
orderedCrossover parent_a parent_b = do
  idxs <- randIndices (V.length parent_a)
  return (orderedCrossoverStat idxs parent_a parent_b)

-- | Ordered crossover with chosen 'slice indexes'
orderedCrossoverStat :: (Eq a, V.Vector v a) => (Int, Int) -> v a -> v a -> (v a, v a)
orderedCrossoverStat (left, right) parent_a parent_b = (child_a, child_b)
      n = right - left
      -- Initialize a child with a slice from its parent
      c_a_mid = V.slice left n parent_a
      c_b_mid = V.slice left n parent_b
      -- Find missing genes from the opposite parents, in the order as they
      -- appear starting from the right of the slice looping around to the left
      c_a_miss = V.filter (`V.notElem` c_a_mid) (V.drop right parent_b V.++ V.take right parent_b)
      c_b_miss = V.filter (`V.notElem` c_b_mid) (V.drop right parent_a V.++ V.take right parent_a)
      splitpos = (V.length parent_a) - right
      (ra, la) = V.splitAt splitpos c_a_miss
      (rb, lb) = V.splitAt splitpos c_b_miss
      child_a = la V.++ c_a_mid V.++ ra
      child_b = lb V.++ c_b_mid V.++ rb

-- | Get two distinct 'Ints' in the interval 0 through 'len', with the lowest
-- number appearing first in the tuple
randIndices :: (MonadRandom m) => Int -> m (Int, Int)
randIndices len = do
  i_left <- getRandomR (0, len-1)
  i_right <- getRandomR (i_left+1, len)
  return (i_left, i_right)
  • \$\begingroup\$ (ra, la) = V.splitAt splitpos c_a_miss. Is that a typo? ra and la probably stand for leftA and rightA, but their positions are swapped. \$\endgroup\$
    – Zeta
    Feb 18, 2017 at 15:34
  • \$\begingroup\$ It turns out correct because the left and right part of the opposite parent is swapped before splitting (see the line c_a_miss). In hindsight I can't remember why I did that in the first place; I'll have to work through the examples again \$\endgroup\$
    – tsorn
    Feb 18, 2017 at 15:46
  • \$\begingroup\$ When finding missing genes from the opposite parent, it's necessary to know if the missing genes came from the right side or the left side of the slice. That's why the parent is swapped left and right at the right end of the slice position before filtering. Before adding the genes to the child they need to be swapped back \$\endgroup\$
    – tsorn
    Feb 18, 2017 at 16:13
  • \$\begingroup\$ I'm not entirely sure why they need to be added back in this order, I think it is to preserve the overall order from both parents when crossing. \$\endgroup\$
    – tsorn
    Feb 18, 2017 at 16:20


Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Browse other questions tagged or ask your own question.