Skip to content
Browse files

Evolution complete

  • Loading branch information...
1 parent af0c5f8 commit ef8b765f74367d59e3409340f7ee544c130f1e10 Mihai Maruseac committed May 15, 2011
Showing with 82 additions and 2 deletions.
  1. +0 −1 Maze/GUI.hs
  2. +82 −1 Maze/Plan.hs
View
1 Maze/GUI.hs
@@ -160,7 +160,6 @@ finishStep ref = do
let newGen = 1 + generation r
-- 3. Get new population by mutation and crossover
let oldPop = V.zip (plans r) (V.fromList l)
- print oldPop
let (plans', g') = runState (newPopulation oldPop) (fromJust $ gen r)
-- 4. Clear the ListStore
mapM_ (\x -> listStoreSetValue ls x (x+1, 0)) [0 .. length l - 1]
View
83 Maze/Plan.hs
@@ -6,14 +6,18 @@ where
import Control.Arrow
import Control.Monad.State
import Data.Array.ST
+import Data.List (sortBy)
import System.Random
import qualified Array as A
import qualified Data.Vector as V
+import qualified Data.Vector.Mutable as VM
import Maze.Maze
import Maze.Types
+import Debug.Trace
+
{- The environment when testing a chromosome. -}
type Env = (Maze, Plan)
@@ -82,5 +86,82 @@ manhattan (x, y) (x', y') = abs (x - x') + abs (y - y')
Returns a new population from an older one, via crossover and mutation.
-}
newPopulation :: V.Vector (Plan, Fitness) -> State StdGen (V.Vector Plan)
-newPopulation = undefined
+newPopulation p = do
+ let sp = sortBy (\(x, y) (x', y') -> y `compare` y') $ V.toList p
+ let len = length sp
+ let slots = V.fromList $ getSlots 1 1 sp
+ let numSlots = snd . V.last $ slots
+ ps <- replicateM len (selectFromPopulation numSlots slots)
+ nps <- mapM cross $ group2 ps
+ newPlans <- mapM mutate $ ungroup2 nps
+ return $ V.fromList newPlans
+
+{-
+Does the crossover between two chromosomes.
+-}
+cross :: (Plan, Plan) -> State StdGen (Plan, Plan)
+cross (p1, p2) = do
+ let l = V.length p1
+ r <- state $ randomR (1, l - 1)
+ let v1 = V.generate l (\x -> if x < r then p1 V.! x else p2 V.! x)
+ let v2 = V.generate l (\x -> if x < r then p2 V.! x else p1 V.! x)
+ return (v1, v2)
+
+{-
+Does the mutation of a chromosome.
+-}
+mutate :: Plan -> State StdGen Plan
+mutate p = do
+ pmutate <- state random
+ if pmutate < (0.1 :: Double)
+ then do
+ let l = V.length p
+ r <- state $ randomR (0, l - 1)
+ rv <- getRandomDir
+ return $ mutatePlan p r rv
+ else return p
+
+{-
+Does the actual mutation of a plan.
+-}
+mutatePlan :: Plan -> Int -> Cardinal -> Plan
+mutatePlan p ix nv = V.modify (\v -> VM.write v ix nv) p
+
+{-
+Selects one guy to participate in next population.
+-}
+selectFromPopulation :: Int -> V.Vector (Plan, Int) -> State StdGen Plan
+selectFromPopulation m ps = do
+ r <- state $ randomR (0, m)
+ return $ findRoulette r ps
+
+{-
+Finds the actual chromosome via roulette.
+-}
+findRoulette :: Int -> V.Vector (Plan, Int) -> Plan
+findRoulette ix ps = fst . V.head $ V.dropWhile (\(x, y) -> ix > y) ps
+
+{-
+Gets the slots for each vector.
+-}
+getSlots :: Int -> Int -> [(Plan, Fitness)] -> [(Plan, Int)]
+getSlots _ _ [] = []
+getSlots ix s ((p, f) : ps) = (p, s) : getSlots (ix + 1) (s + ix + 1) ps
+
+{-
+Transforms a list of an even number of elements into a list of pairs from
+adjacent elements. It the list has an odd number of elements, the last one is
+ignored.
+-}
+group2 :: [a] -> [(a, a)]
+group2 (x:y:rs) = (x, y) : group2 rs
+group2 _ = []
+
+{-
+Inverse of the above operation. Always yields a list with an even number of
+elements (thus, it is not really an inverse in the other case).
+-}
+ungroup2 :: [(a, a)] -> [a]
+ungroup2 ((x, y) : xys) = x : y : ungroup2 xys
+ungroup2 _ = []

0 comments on commit ef8b765

Please sign in to comment.
Something went wrong with that request. Please try again.