Permalink
Browse files

ok

  • Loading branch information...
banacorn committed Mar 30, 2013
1 parent d2991c1 commit 46dab33840cdff271d847488e6269a282f1dffb7
Showing with 57 additions and 34 deletions.
  1. +57 −34 ga.hs
View
91 ga.hs
@@ -4,6 +4,7 @@
module GA where
import Control.Monad (forever, replicateM)
+import Data.List (intercalate)
import qualified System.Random.MWC as MWC
import qualified Control.Monad.Primitive as Prim
@@ -16,8 +17,8 @@ class Phenotype p where
evaluate :: p -> Int
class Eq g => Genotype g where
- mutate :: Gen -> g -> IO g
- crossover :: Gen -> [g] -> IO [g]
+ mutate :: Gen -> Int -> g -> IO g
+ crossover :: Gen -> (g, g) -> IO (g, g)
initialize :: Gen -> IO g
class (Genotype genotype, Phenotype phenotype) => Representation genotype phenotype | phenotype -> genotype, genotype -> phenotype where
@@ -29,24 +30,23 @@ data Individual g = Individual g Int
instance Eq g => Eq (Individual g) where
Individual a _ == Individual b _ = a == b
-
instance Eq g => Ord (Individual g) where
compare (Individual _ a) (Individual _ b) = compare a b
data Population g p = Population Config [Individual g]
instance (Show g, Show p) => Show (Population g p) where
show (Population config population) =
- show population ++
+ chromosomes ++
"\nsize " ++ (show . size $ config)
- --"\nseed " ++ (show . MWC.fromSeed . seed $ config)
-
+ where chromosomes = intercalate "\n" $ map show population
instance Show g => Show (Individual g) where
- show (Individual chromosome fitness) = " " ++ show fitness ++ " " ++ show chromosome ++ " "
+ show (Individual chromosome fitness) = " " ++ show fitness ++ " " ++ show chromosome ++ " "
data Config = Config {
size :: Int,
+ mutationProb :: Double,
seed :: Seed
} deriving (Show)
@@ -58,6 +58,7 @@ saveGen config gen = do
seed' <- MWC.save gen
return $ Config {
size = size config,
+ mutationProb = mutationProb config,
seed = seed'
}
where seed' = seed config
@@ -105,27 +106,47 @@ rouletteWheel gen population = do
| otherwise = spinWheel (number - fitness) xs
where (Individual _ fitness) = x
-evaluateP :: (Representation g p) => Population g p -> IO (Population g p)
-evaluateP (Population crossover population) = do
+crossoverP :: (Representation g p) => Population g p -> IO (Population g p)
+crossoverP (Population config population) = do
+ gen <- restoreGen config
+ (p0', p1') <- fmap unzip $ mapM (crossoverI gen) (group population)
+ let population' = p0' ++ p1'
+ config' <- saveGen config gen
+ return (Population config' population')
+ where group [] = []
+ group [x] = [(x, x)]
+ group (x:y:xs) = (x, y) : group xs
+ crossoverI gen (Individual a _, Individual b _) = do
+ (a', b') <- crossover gen (a, b)
+ return (Individual a' 0, Individual b' 0)
+
+mutateP :: (Representation g p) => Population g p -> IO (Population g p)
+mutateP (Population config population) = do
+ gen <- restoreGen config
+ population' <- mapM (mutateI gen (0)) population
+ config' <- saveGen config gen
+ return $ Population config' population
+ where mutateI gen prob (Individual chromosome _) = do
+ chromosome' <- mutate gen prob chromosome
+ return $ Individual chromosome' 0
print' :: Show a => a -> IO a
print' a = putStrLn (show a) >> return a
-avg :: (Representation g p, Fractional a) => Population g p -> IO a
-avg (Population config population) = return $ (fromIntegral summation) / (fromIntegral . size $ config)
+
+iterateM :: Monad m => Int -> (a -> m a) -> m a -> m a
+iterateM 0 f c = c
+iterateM n f c = iterateM (n - 1) f c >>= f
+
+printAvg :: (Representation g p) => Population g p -> IO (Population g p)
+printAvg (Population config population) = do
+ putStrLn $ "average " ++ show ((fromIntegral summation) / (fromIntegral . size $ config))
+ return (Population config population)
where summation = foldl (\ e (Individual _ f) -> e + f ) 0 population
main = do
- unicorn <- initializeP unicornConfig :: IO (Population BoolString BitString)
-
- a <- evaluateP unicorn >>= selectP rouletteWheel
- avg a >>= print
- b <- selectP rouletteWheel a
- avg b >>= print
- c <- selectP rouletteWheel b
- avg c >>= print
- d <- selectP rouletteWheel c
- avg d >>= print
+ unicorn <- initializeP unicornConfig >>= evaluateP :: IO (Population BoolString BitString)
+ iterateM 3000 (\ s -> printAvg s >>= selectP tournament >>= crossoverP >>= mutateP >>= evaluateP) (return unicorn)
@@ -134,27 +155,28 @@ data BitString = BitString [Int] deriving Show
instance Genotype BoolString where
- initialize gen = fmap (BoolString . map even . V.toList) (MWC.uniformVector gen 10 :: IO (V.Vector Int))
- mutate gen (BoolString list) = do
- n <- MWC.uniformR (0, len - 1) gen
- return . BoolString $ mutate n list
- where len = length list
- mutate _ [] = []
- mutate 0 (b:bs) = not b : bs
- mutate n (b:bs) = b : mutate (n - 1) bs
- crossover gen [BoolString l0, BoolString l1] = do
+ initialize gen = fmap (BoolString . map even . V.toList) (MWC.uniformVector gen 100 :: IO (V.Vector Int))
+ mutate gen prob boolString = return boolString
+ --mutate gen prob (BoolString list) = do
+ -- n <- MWC.uniform gen
+ -- --return . BoolString $ mutate' n list
+ -- --where len = length list
+ -- -- mutate' _ [] = []
+ -- -- mutate' 0 (b:bs) = not b : bs
+ -- -- mutate' n (b:bs) = b : mutate' (n - 1) bs
+ crossover gen (BoolString l0, BoolString l1) = do
n <- MWC.uniformR (0, len - 1) gen :: IO Int
let (head0, tail0) = splitAt n l0
let (head1, tail1) = splitAt n l1
- return [BoolString (head0 ++ tail1), BoolString (head1 ++ tail0)]
+ return (BoolString (head0 ++ tail1), BoolString (head1 ++ tail0))
where len = min (length l0) (length l1)
instance Show BoolString where
show (BoolString boolString) = map toChar boolString
- where toChar True = '*'
- toChar False = '_'
+ where toChar True = '1'
+ toChar False = '0'
asBoolString :: BoolString -> BoolString
asBoolString = id
@@ -169,7 +191,8 @@ instance Representation BoolString BitString where
toBit False = 0
unicornConfig = Config {
- size = 100,
+ size = 20,
+ mutationProb = 0.3,
seed = MWC.toSeed (V.singleton 42)
}

0 comments on commit 46dab33

Please sign in to comment.