Skip to content

Instantly share code, notes, and snippets.

@blackwithwhite666

blackwithwhite666/.gitignore

Created April 4, 2012 06:30
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save blackwithwhite666/2298992 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save blackwithwhite666/2298992 to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. Lipin Dmitriy revised this gist Jan 7, 2014. 1 changed file with 25 additions and 25 deletions.
    50 changes: 25 additions & 25 deletions gen.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -1,12 +1,12 @@
    -- gen.hs
    -- http://habrahabr.ru/post/128704/
    import Control.Monad
    import Control.Monad.Random
    import Control.Monad.Trans
    import Control.Monad.Maybe
    import Data.List
    import System.Random
    import Data.Maybe
    import qualified Control.Monad as Monad
    import qualified Control.Monad.Random as Random
    import qualified Control.Monad.Trans as Trans
    import qualified Control.Monad.Maybe as Maybe
    import Data.List (nub)
    import System.Random (RandomGen, newStdGen)
    import Data.Maybe (isNothing)

    -- Common
    invert :: (Integral a, Fractional b) => [a] -> [b]
    @@ -24,10 +24,10 @@ genUnique (x:xs) = if (fst x) == (snd x)

    randInt :: Int -> Int -> IO Int
    randInt start end = do
    value <- evalRandIO range
    value <- Random.evalRandIO range
    return value
    where
    range = getRandomR (start, end)
    range = Random.getRandomR (start, end)

    -- Solution definition
    data Solution = Solution Int Int Int Int
    @@ -47,7 +47,7 @@ instance Equation Solution where
    equationDiff a = abs (equationResult a - 30)

    randomSolution = do
    params <- replicateM 4 $ randInt (-30) 30
    params <- Monad.replicateM 4 $ randInt (-30) 30
    return $ createSolution params

    createSolution params = (Solution (params!!0) (params!!1) (params!!2) (params!!3))
    @@ -128,11 +128,11 @@ class GeneUtils a where
    produceParents :: [a] -> IO [(Genome, Genome)]

    instance GeneUtils Gene where
    selectRandom gen genes = evalRand m gen
    selectRandom gen genes = Random.evalRand m gen
    where
    toTuple (Gene g l) = (g, l)
    weights = map toTuple genes
    m = sequence . repeat . fromList $ weights
    m = sequence . repeat . Random.fromList $ weights

    produceParents genes = do
    gen <- newStdGen
    @@ -145,10 +145,10 @@ data GenePool = GenePool

    class GenePoolUtils a where
    computeGenes :: a -> Maybe [Gene]
    generateParents :: a -> MaybeT IO [(Genome, Genome)]
    generateChilds :: a -> MaybeT IO [Genome]
    generateParents :: a -> Maybe.MaybeT IO [(Genome, Genome)]
    generateChilds :: a -> Maybe.MaybeT IO [Genome]
    findResults :: a -> [Genome]
    runEvolution :: a -> MaybeT IO [Genome]
    runEvolution :: a -> Maybe.MaybeT IO [Genome]

    instance GenePoolUtils GenePool where
    computeGenes (GenePool gs) = do
    @@ -161,36 +161,36 @@ instance GenePoolUtils GenePool where
    return $ (map createGene) $ (zip gs) $ likelihoods

    generateParents pool = do
    genes <- MaybeT $ do return $ computeGenes pool
    pairs <- lift $ produceParents genes
    genes <- Maybe.MaybeT $ do return $ computeGenes pool
    pairs <- Trans.lift $ produceParents genes
    return $ pairs

    generateChilds pool = do
    parents <- generateParents pool
    childs <- lift . sequence $ take l (breedChilds parents)
    childs <- Trans.lift . sequence $ take l (breedChilds parents)
    return $ take l $ nub childs
    where
    l = length $ genomes pool

    findResults pool = nub $ do
    (genome, fitness) <- zip gs $ map computeFitness gs
    guard $ isNothing fitness
    Monad.guard $ isNothing fitness
    return genome
    where
    gs = genomes pool

    runEvolution pool = do
    newPool <- lift $ evolve pool
    newPool <- Trans.lift $ evolve pool
    return $ findResults newPool
    where
    evolveOne :: GenePool -> MaybeT IO GenePool
    evolveOne :: GenePool -> Maybe.MaybeT IO GenePool
    evolveOne pool = do
    lift $ print pool
    Trans.lift $ print pool
    childs <- generateChilds pool
    return (GenePool childs)
    evolve :: GenePool -> IO GenePool
    evolve pool = do
    maybeNextPool <- runMaybeT $ evolveOne pool
    maybeNextPool <- Maybe.runMaybeT $ evolveOne pool
    case maybeNextPool of
    Nothing -> return pool
    Just nextPool -> do
    @@ -200,8 +200,8 @@ instance GenePoolUtils GenePool where

    -- run solver
    main = do
    gs <- replicateM populationSize generateGenome
    results <- runMaybeT $ runEvolution (GenePool gs)
    gs <- Monad.replicateM populationSize generateGenome
    results <- Maybe.runMaybeT $ runEvolution (GenePool gs)
    print $ results
    where
    populationSize = 128
  2. Lipin Dmitriy revised this gist Jan 7, 2014. 2 changed files with 152 additions and 137 deletions.
    12 changes: 12 additions & 0 deletions .gitignore
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,12 @@
    dist
    cabal-dev
    *.o
    *.hi
    *.chi
    *.chs.h
    .virthualenv
    .hsenv
    .cabal-sandbox/
    cabal.sandbox.config
    cabal.config
    gen
    277 changes: 140 additions & 137 deletions gen.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -6,7 +6,7 @@ import Control.Monad.Trans
    import Control.Monad.Maybe
    import Data.List
    import System.Random
    import Maybe
    import Data.Maybe

    -- Common
    invert :: (Integral a, Fractional b) => [a] -> [b]
    @@ -19,186 +19,189 @@ tupleGen (a:b:xs) = (a,b): tupleGen xs
    genUnique :: (Eq a) => [(a, a)] -> [(a, a)]
    genUnique [] = []
    genUnique (x:xs) = if (fst x) == (snd x)
    then genUnique xs
    else x : genUnique xs
    then genUnique xs
    else x : genUnique xs

    randInt :: Int -> Int -> IO Int
    randInt start end = do
    value <- evalRandIO range
    return value
    where range = getRandomR (start, end)
    value <- evalRandIO range
    return value
    where
    range = getRandomR (start, end)

    -- Solution definition
    data Solution = Solution Int Int Int Int
    deriving (Eq, Show)
    deriving (Eq, Show)

    class Equation a where
    equationResult :: a -> Int
    equationDiff :: a -> Int
    randomSolution :: IO a
    createSolution :: [Int] -> a
    solutionToList :: a -> [Int]
    mutateSolution :: a -> IO a
    equationResult :: a -> Int
    equationDiff :: a -> Int
    randomSolution :: IO a
    createSolution :: [Int] -> a
    solutionToList :: a -> [Int]
    mutateSolution :: a -> IO a

    instance Equation Solution where
    equationResult (Solution a b c d) = a + b * 2 + c * 3 + d * 4
    equationResult (Solution a b c d) = a + b * 2 + c * 3 + d * 4

    equationDiff a = abs (equationResult a - 30)
    equationDiff a = abs (equationResult a - 30)

    randomSolution = do
    params <- replicateM 4 $ randInt (-30) 30
    return $ createSolution params
    randomSolution = do
    params <- replicateM 4 $ randInt (-30) 30
    return $ createSolution params

    createSolution params = (Solution (params!!0) (params!!1) (params!!2) (params!!3))
    createSolution params = (Solution (params!!0) (params!!1) (params!!2) (params!!3))

    solutionToList (Solution a b c d) = [a, b, c, d]
    solutionToList (Solution a b c d) = [a, b, c, d]

    mutateSolution s = do
    mutatedParams <- mutate $ solutionToList s
    return $ createSolution mutatedParams
    where
    mutateValue :: Int -> IO Int
    mutateValue param = do
    chance <- randInt 0 1
    value <- randInt (-30) 30
    return $ if chance == 1 then value else param
    mutate :: [Int] -> IO [Int]
    mutate params = sequence $ do
    param <- params
    return $ mutateValue param
    mutateSolution s = do
    mutatedParams <- mutate $ solutionToList s
    return $ createSolution mutatedParams
    where
    mutateValue :: Int -> IO Int
    mutateValue param = do
    chance <- randInt 0 1
    value <- randInt (-30) 30
    return $ if chance == 1 then value else param
    mutate :: [Int] -> IO [Int]
    mutate params = sequence $ do
    param <- params
    return $ mutateValue param

    -- Genome definition
    data Genome = Genome {
    solution :: Solution
    } deriving (Eq, Show)
    data Genome = Genome
    { solution :: Solution
    } deriving (Eq, Show)

    class GenomeUtils a where
    computeFitness :: a -> Maybe Int
    createChild :: (a, a) -> IO a
    breedChilds :: [(a, a)] -> [IO a]
    generateGenome :: IO a
    mutateGenome :: a -> IO a
    computeFitness :: a -> Maybe Int
    createChild :: (a, a) -> IO a
    breedChilds :: [(a, a)] -> [IO a]
    generateGenome :: IO a
    mutateGenome :: a -> IO a

    instance GenomeUtils Genome where
    computeFitness (Genome s)
    | diff == 0 = Nothing
    | otherwise = Just diff
    where diff = equationDiff s

    createChild (p1, p2) = do
    crossover <- randInt 0 3
    first <- randInt 0 1
    let child = case first of
    0 -> combine p1 p2 crossover
    1 -> combine p2 p1 crossover
    mutatedChild <- mutateGenome child
    return child
    where
    combine :: Genome -> Genome -> Int -> Genome
    combine (Genome s1) (Genome s2) crossover = (Genome (createSolution $ concat [start, end]))
    where
    start = fst $ splitAt crossover $ solutionToList s1
    end = snd $ splitAt crossover $ solutionToList s2


    breedChilds parents = convert parents
    where
    convert :: [(Genome, Genome)] -> [IO Genome]
    convert [] = []
    convert (x:xs) = createChild x : convert xs

    generateGenome = do
    solution <- randomSolution
    return (Genome solution)

    mutateGenome (Genome s) = do
    mutated <- mutateSolution s
    return (Genome mutated)


    computeFitness (Genome s)
    | diff == 0 = Nothing
    | otherwise = Just diff
    where
    diff = equationDiff s

    createChild (p1, p2) = do
    crossover <- randInt 0 3
    first <- randInt 0 1
    let child = flippedCombine first p1 p2 crossover
    mutatedChild <- mutateGenome child
    return child
    where
    combine :: Genome -> Genome -> Int -> Genome
    combine (Genome s1) (Genome s2) crossover = (Genome (createSolution $ concat [start, end]))
    where
    start = fst $ splitAt crossover $ solutionToList s1
    end = snd $ splitAt crossover $ solutionToList s2
    flippedCombine first p1 p2 crossover
    | first == 0 = combine p1 p2 crossover
    | otherwise = combine p2 p1 crossover

    breedChilds parents = convert parents
    where
    convert :: [(Genome, Genome)] -> [IO Genome]
    convert [] = []
    convert (x:xs) = createChild x : convert xs

    generateGenome = do
    solution <- randomSolution
    return (Genome solution)

    mutateGenome (Genome s) = do
    mutated <- mutateSolution s
    return (Genome mutated)

    -- Gene definition
    data Gene = Gene {
    genome :: Genome,
    likelihood :: Rational
    } deriving (Eq, Show)
    data Gene = Gene
    { genome :: Genome
    , likelihood :: Rational
    } deriving (Eq, Show)

    class GeneUtils a where
    selectRandom :: RandomGen g => g -> [a] -> [Genome]
    produceParents :: [a] -> IO [(Genome, Genome)]
    selectRandom :: RandomGen g => g -> [a] -> [Genome]
    produceParents :: [a] -> IO [(Genome, Genome)]

    instance GeneUtils Gene where
    selectRandom gen genes = evalRand m gen
    where
    toTuple (Gene g l) = (g, l)
    weights = map toTuple genes
    m = sequence . repeat . fromList $ weights
    selectRandom gen genes = evalRand m gen
    where
    toTuple (Gene g l) = (g, l)
    weights = map toTuple genes
    m = sequence . repeat . fromList $ weights

    produceParents genes = do
    gen <- newStdGen
    return $ genUnique $ tupleGen $ selectRandom gen genes
    produceParents genes = do
    gen <- newStdGen
    return $ genUnique $ tupleGen $ selectRandom gen genes

    -- GenePool definition
    data GenePool = GenePool {
    genomes :: [Genome]
    } deriving (Show)
    data GenePool = GenePool
    { genomes :: [Genome]
    } deriving (Show)

    class GenePoolUtils a where
    computeGenes :: a -> Maybe [Gene]
    generateParents :: a -> MaybeT IO [(Genome, Genome)]
    generateChilds :: a -> MaybeT IO [Genome]
    findResults :: a -> [Genome]
    runEvolution :: a -> MaybeT IO [Genome]
    computeGenes :: a -> Maybe [Gene]
    generateParents :: a -> MaybeT IO [(Genome, Genome)]
    generateChilds :: a -> MaybeT IO [Genome]
    findResults :: a -> [Genome]
    runEvolution :: a -> MaybeT IO [Genome]

    instance GenePoolUtils GenePool where
    computeGenes (GenePool gs) = do
    fitnesses <- sequence $ map computeFitness gs
    let
    invertedFitnesses = invert fitnesses
    mult = ((100/) . sum) invertedFitnesses
    likelihoods = map (*mult) invertedFitnesses
    createGene (g, l) = Gene g l
    return $ (map createGene) $ (zip gs) $ likelihoods
    fitnesses <- sequence $ map computeFitness gs
    let
    invertedFitnesses = invert fitnesses
    mult = ((100/) . sum) invertedFitnesses
    likelihoods = map (*mult) invertedFitnesses
    createGene (g, l) = Gene g l
    return $ (map createGene) $ (zip gs) $ likelihoods

    generateParents pool = do
    genes <- MaybeT $ do return $ computeGenes pool
    pairs <- lift $ produceParents genes
    return $ pairs
    genes <- MaybeT $ do return $ computeGenes pool
    pairs <- lift $ produceParents genes
    return $ pairs

    generateChilds pool = do
    parents <- generateParents pool
    childs <- lift . sequence $ take l (breedChilds parents)
    return $ take l $ nub childs
    where l = length $ genomes pool
    parents <- generateParents pool
    childs <- lift . sequence $ take l (breedChilds parents)
    return $ take l $ nub childs
    where
    l = length $ genomes pool

    findResults pool = nub $ do
    (genome, fitness) <- zip gs $ map computeFitness gs
    guard $ isNothing fitness
    return genome
    where gs = genomes pool
    (genome, fitness) <- zip gs $ map computeFitness gs
    guard $ isNothing fitness
    return genome
    where
    gs = genomes pool

    runEvolution pool = do
    newPool <- lift $ evolve pool
    return $ findResults newPool
    where
    evolveOne :: GenePool -> MaybeT IO GenePool
    evolveOne pool = do
    lift $ print pool
    childs <- generateChilds pool
    return (GenePool childs)
    evolve :: GenePool -> IO GenePool
    evolve pool = do
    maybeNextPool <- runMaybeT $ evolveOne pool
    case maybeNextPool of
    Nothing -> return pool
    Just nextPool -> do
    pool <- evolve nextPool
    return pool
    newPool <- lift $ evolve pool
    return $ findResults newPool
    where
    evolveOne :: GenePool -> MaybeT IO GenePool
    evolveOne pool = do
    lift $ print pool
    childs <- generateChilds pool
    return (GenePool childs)
    evolve :: GenePool -> IO GenePool
    evolve pool = do
    maybeNextPool <- runMaybeT $ evolveOne pool
    case maybeNextPool of
    Nothing -> return pool
    Just nextPool -> do
    pool <- evolve nextPool
    return pool


    -- run solver
    main = do
    gs <- replicateM populationSize generateGenome
    results <- runMaybeT $ runEvolution (GenePool gs)
    print $ results
    where populationSize = 5
    gs <- replicateM populationSize generateGenome
    results <- runMaybeT $ runEvolution (GenePool gs)
    print $ results
    where
    populationSize = 128
  3. blackwithwhite666 created this gist Apr 4, 2012.
    204 changes: 204 additions & 0 deletions gen.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,204 @@
    -- gen.hs
    -- http://habrahabr.ru/post/128704/
    import Control.Monad
    import Control.Monad.Random
    import Control.Monad.Trans
    import Control.Monad.Maybe
    import Data.List
    import System.Random
    import Maybe

    -- Common
    invert :: (Integral a, Fractional b) => [a] -> [b]
    invert xs = map (\x -> 1 / fromIntegral x) xs

    tupleGen :: [a] -> [(a, a)]
    tupleGen [] = []
    tupleGen (a:b:xs) = (a,b): tupleGen xs

    genUnique :: (Eq a) => [(a, a)] -> [(a, a)]
    genUnique [] = []
    genUnique (x:xs) = if (fst x) == (snd x)
    then genUnique xs
    else x : genUnique xs

    randInt :: Int -> Int -> IO Int
    randInt start end = do
    value <- evalRandIO range
    return value
    where range = getRandomR (start, end)

    -- Solution definition
    data Solution = Solution Int Int Int Int
    deriving (Eq, Show)

    class Equation a where
    equationResult :: a -> Int
    equationDiff :: a -> Int
    randomSolution :: IO a
    createSolution :: [Int] -> a
    solutionToList :: a -> [Int]
    mutateSolution :: a -> IO a

    instance Equation Solution where
    equationResult (Solution a b c d) = a + b * 2 + c * 3 + d * 4

    equationDiff a = abs (equationResult a - 30)

    randomSolution = do
    params <- replicateM 4 $ randInt (-30) 30
    return $ createSolution params

    createSolution params = (Solution (params!!0) (params!!1) (params!!2) (params!!3))

    solutionToList (Solution a b c d) = [a, b, c, d]

    mutateSolution s = do
    mutatedParams <- mutate $ solutionToList s
    return $ createSolution mutatedParams
    where
    mutateValue :: Int -> IO Int
    mutateValue param = do
    chance <- randInt 0 1
    value <- randInt (-30) 30
    return $ if chance == 1 then value else param
    mutate :: [Int] -> IO [Int]
    mutate params = sequence $ do
    param <- params
    return $ mutateValue param

    -- Genome definition
    data Genome = Genome {
    solution :: Solution
    } deriving (Eq, Show)

    class GenomeUtils a where
    computeFitness :: a -> Maybe Int
    createChild :: (a, a) -> IO a
    breedChilds :: [(a, a)] -> [IO a]
    generateGenome :: IO a
    mutateGenome :: a -> IO a

    instance GenomeUtils Genome where
    computeFitness (Genome s)
    | diff == 0 = Nothing
    | otherwise = Just diff
    where diff = equationDiff s

    createChild (p1, p2) = do
    crossover <- randInt 0 3
    first <- randInt 0 1
    let child = case first of
    0 -> combine p1 p2 crossover
    1 -> combine p2 p1 crossover
    mutatedChild <- mutateGenome child
    return child
    where
    combine :: Genome -> Genome -> Int -> Genome
    combine (Genome s1) (Genome s2) crossover = (Genome (createSolution $ concat [start, end]))
    where
    start = fst $ splitAt crossover $ solutionToList s1
    end = snd $ splitAt crossover $ solutionToList s2


    breedChilds parents = convert parents
    where
    convert :: [(Genome, Genome)] -> [IO Genome]
    convert [] = []
    convert (x:xs) = createChild x : convert xs

    generateGenome = do
    solution <- randomSolution
    return (Genome solution)

    mutateGenome (Genome s) = do
    mutated <- mutateSolution s
    return (Genome mutated)



    -- Gene definition
    data Gene = Gene {
    genome :: Genome,
    likelihood :: Rational
    } deriving (Eq, Show)

    class GeneUtils a where
    selectRandom :: RandomGen g => g -> [a] -> [Genome]
    produceParents :: [a] -> IO [(Genome, Genome)]

    instance GeneUtils Gene where
    selectRandom gen genes = evalRand m gen
    where
    toTuple (Gene g l) = (g, l)
    weights = map toTuple genes
    m = sequence . repeat . fromList $ weights

    produceParents genes = do
    gen <- newStdGen
    return $ genUnique $ tupleGen $ selectRandom gen genes

    -- GenePool definition
    data GenePool = GenePool {
    genomes :: [Genome]
    } deriving (Show)

    class GenePoolUtils a where
    computeGenes :: a -> Maybe [Gene]
    generateParents :: a -> MaybeT IO [(Genome, Genome)]
    generateChilds :: a -> MaybeT IO [Genome]
    findResults :: a -> [Genome]
    runEvolution :: a -> MaybeT IO [Genome]

    instance GenePoolUtils GenePool where
    computeGenes (GenePool gs) = do
    fitnesses <- sequence $ map computeFitness gs
    let
    invertedFitnesses = invert fitnesses
    mult = ((100/) . sum) invertedFitnesses
    likelihoods = map (*mult) invertedFitnesses
    createGene (g, l) = Gene g l
    return $ (map createGene) $ (zip gs) $ likelihoods

    generateParents pool = do
    genes <- MaybeT $ do return $ computeGenes pool
    pairs <- lift $ produceParents genes
    return $ pairs

    generateChilds pool = do
    parents <- generateParents pool
    childs <- lift . sequence $ take l (breedChilds parents)
    return $ take l $ nub childs
    where l = length $ genomes pool

    findResults pool = nub $ do
    (genome, fitness) <- zip gs $ map computeFitness gs
    guard $ isNothing fitness
    return genome
    where gs = genomes pool

    runEvolution pool = do
    newPool <- lift $ evolve pool
    return $ findResults newPool
    where
    evolveOne :: GenePool -> MaybeT IO GenePool
    evolveOne pool = do
    lift $ print pool
    childs <- generateChilds pool
    return (GenePool childs)
    evolve :: GenePool -> IO GenePool
    evolve pool = do
    maybeNextPool <- runMaybeT $ evolveOne pool
    case maybeNextPool of
    Nothing -> return pool
    Just nextPool -> do
    pool <- evolve nextPool
    return pool


    -- run solver
    main = do
    gs <- replicateM populationSize generateGenome
    results <- runMaybeT $ runEvolution (GenePool gs)
    print $ results
    where populationSize = 5