Permalink
Browse files

fuck you

  • Loading branch information...
1 parent 86ccadb commit d2991c190f02676b88f00b23972cc2acb39b6db4 @banacorn committed Mar 28, 2013
Showing with 188 additions and 1 deletion.
  1. +12 −1 data.hs
  2. +176 −0 ga.hs
View
13 data.hs
@@ -1,3 +1,5 @@
+import Data.List
+
sechs = [
[35,36,36,36,37,39,40,41,41,42,44,44,46,46,46,46,47,48,48,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
[35,38,38,39,38,40,40,42,42,44,43,46,46,46,47,47,49,49,49,49,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50],
@@ -36,6 +38,8 @@ drei = [
[34,34,34,34,34,35,35,35,38,39,39,40,39,38,39,38,38,40,41,41,40,40,41,41,41,40,42,40,41,42,41,41,41,41,41,41,41,42,42,41,41,42,42,42,44,43,43,44,44,44,44,44,45,45,44,46,44,45,46,46,46,45,47,46,47,46,46,46,47,46,47,46,46,47,46,46,47,47,47,47,47,47,48,48,48,48,47,47,48,48,47,48,48,48,48,48,48,48,48,48],
[34,35,35,38,35,35,35,37,37,37,37,36,37,37,38,37,37,39,40,39,39,39,39,38,39,40,40,40,41,42,42,41,42,43,45,45,44,44,44,45,43,43,45,45,45,44,45,46,46,46,47,46,48,46,46,47,47,47,46,47,46,47,47,47,47,47,47,48,47,47,49,48,48,49,48,48,48,48,48,48,48,47,47,48,47,47,48,48,48,47,46,48,48,47,47,48,48,48,48,48]
]
+ --seeds <- map (MWC.toSeed . V.singleton) . V.toList <$> MWC.uniformVector gen (size config) :: IO [Seed]
+
fier = [
[33,36,33,35,34,33,34,36,33,36,35,34,34,33,32,33,33,32,33,32,34,34,34,32,33,37,33,34,32,34,33,34,35,34,33,35,32,33,34,32,34,34,33,35,35,35,34,35,32,32,31,33,33,33,31,32,33,34,36,37,33,32,32,34,33,33,32,32,29,31,31,30,32,32,30,29,30,31,31,29,31,31,30,29,28,29,30,30,30,29,30,30,29,29,28,30,29,30,32,30],
@@ -48,4 +52,11 @@ fier = [
[34,35,34,35,33,35,35,32,33,33,32,34,33,33,31,32,33,31,31,31,31,30,31,31,34,32,34,34,34,33,32,31,32,33,34,32,33,33,34,33,33,33,33,32,34,35,32,32,31,33,33,32,33,32,34,33,35,36,34,34,34,35,34,33,33,33,32,34,34,35,34,34,34,36,33,33,32,31,33,35,35,32,35,33,33,33,32,34,34,35,34,32,32,30,30,31,30,30,31,31],
[34,33,36,33,33,34,34,34,34,34,33,34,33,32,32,32,34,34,34,34,32,34,34,32,34,34,34,34,34,33,34,33,33,34,33,33,34,32,32,32,33,35,34,34,33,33,34,33,32,33,33,33,34,34,32,32,36,36,36,34,35,34,33,32,36,35,34,34,34,34,35,35,34,32,35,34,33,32,32,33,34,33,32,35,34,33,32,32,32,31,31,34,32,32,30,31,31,31,31,32],
[35,33,35,37,38,34,36,35,35,32,33,33,33,34,35,32,35,33,36,36,35,34,37,35,35,34,35,34,35,36,37,33,34,35,36,33,34,38,39,36,36,37,35,36,35,35,35,35,34,35,34,33,34,32,32,32,32,33,33,36,33,34,34,34,35,34,33,34,35,33,34,34,35,32,34,33,34,34,35,34,33,33,35,34,34,34,34,34,35,34,33,34,34,34,34,34,34,34,33,34]
- ]
+ ]
+
+avg = map (\n -> fromIntegral n / 10) . map sum . transpose
+
+plot a b c d= intercalate ", " . map (\(i, n, m, o, p) -> "[" ++ show i ++ ", " ++ show n ++ ", " ++ show m ++ ", " ++ show o ++ ", " ++ show p ++ "]") $ zip5 [0..] (avg a) (avg b) (avg c) (avg d)
+
+
+
View
176 ga.hs
@@ -0,0 +1,176 @@
+ {-# LANGUAGE MultiParamTypeClasses #-}
+ {-# LANGUAGE FunctionalDependencies #-}
+
+module GA where
+
+import Control.Monad (forever, replicateM)
+
+import qualified System.Random.MWC as MWC
+import qualified Control.Monad.Primitive as Prim
+import qualified Data.Vector as V
+
+type Seed = MWC.Seed
+type Gen = MWC.Gen (Prim.PrimState IO)
+
+class Phenotype p where
+ evaluate :: p -> Int
+
+class Eq g => Genotype g where
+ mutate :: Gen -> g -> IO g
+ crossover :: Gen -> [g] -> IO [g]
+ initialize :: Gen -> IO g
+
+class (Genotype genotype, Phenotype phenotype) => Representation genotype phenotype | phenotype -> genotype, genotype -> phenotype where
+ encode :: phenotype -> genotype
+ decode :: genotype -> phenotype
+
+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 ++
+ "\nsize " ++ (show . size $ config)
+ --"\nseed " ++ (show . MWC.fromSeed . seed $ config)
+
+
+instance Show g => Show (Individual g) where
+ show (Individual chromosome fitness) = " " ++ show fitness ++ " " ++ show chromosome ++ " "
+
+data Config = Config {
+ size :: Int,
+ seed :: Seed
+} deriving (Show)
+
+restoreGen :: Config -> IO Gen
+restoreGen config = MWC.restore (seed config)
+
+saveGen :: Config -> Gen -> IO Config
+saveGen config gen = do
+ seed' <- MWC.save gen
+ return $ Config {
+ size = size config,
+ seed = seed'
+ }
+ where seed' = seed config
+
+initializeP :: (Representation g p) => Config -> IO (Population g p)
+initializeP config = do
+ gen <- restoreGen config
+ chomosomes <- replicateM (size config) (initialize gen)
+ config' <- saveGen config gen
+ return $ Population config' (fmap (flip Individual 0) chomosomes)
+
+evaluateP :: (Representation g p) => Population g p -> IO (Population g p)
+evaluateP (Population config population) = return $ Population config population'
+ where population' = map evaluateI population
+ evaluateI (Individual chomosome _) = Individual chomosome (evaluate (decode chomosome))
+
+selectP :: (Representation g p) => (Gen -> [Individual g] -> IO (Individual g)) -> Population g p -> IO (Population g p)
+selectP f (Population config population) = do
+ gen <- restoreGen config
+ population' <- replicateM populationSize (f gen population)
+ config' <- saveGen config gen
+ return $ Population config' population'
+ where populationSize = size config
+
+tournament :: (Representation g p) => Gen -> [Individual g] -> IO (Individual g)
+tournament gen population = do
+ indexA <- MWC.uniformR (0, populationSize - 1) gen
+ indexB <- MWC.uniformR (0, populationSize - 1) gen
+ let a = population !! indexA
+ let b = population !! indexB
+ return $ max a b
+ where populationSize = length population
+
+rouletteWheel :: (Representation g p) => Gen -> [Individual g] -> IO (Individual g)
+rouletteWheel gen population = do
+ let total = totalFitness population
+ number <- MWC.uniformR (0, total) gen
+ return (spinWheel number population)
+ where
+ totalFitness [] = 0
+ totalFitness ((Individual _ fitness):xs) = fitness + totalFitness xs
+ spinWheel number [x] = x
+ spinWheel number (x:xs)
+ | number <= fitness = x
+ | 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
+
+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)
+ 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
+
+
+
+data BoolString = BoolString [Bool] deriving Eq
+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
+ 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)]
+ where len = min (length l0) (length l1)
+
+
+
+instance Show BoolString where
+ show (BoolString boolString) = map toChar boolString
+ where toChar True = '*'
+ toChar False = '_'
+
+asBoolString :: BoolString -> BoolString
+asBoolString = id
+
+instance Phenotype BitString where
+ evaluate (BitString bitString) = sum bitString
+
+instance Representation BoolString BitString where
+ encode (BitString bitString) = BoolString . map odd $ bitString
+ decode (BoolString boolString) = BitString . map toBit $ boolString
+ where toBit True = 1
+ toBit False = 0
+
+unicornConfig = Config {
+ size = 100,
+ seed = MWC.toSeed (V.singleton 42)
+}
+
+unicorn = Population unicornConfig []

0 comments on commit d2991c1

Please sign in to comment.