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
Solve Diophantine equation with Haskell
Raw
.gitignore
dist
cabal-dev
*.o
*.hi
*.chi
*.chs.h
.virthualenv
.hsenv
.cabal-sandbox/
cabal.sandbox.config
cabal.config
gen
Raw
gen.hs
-- gen.hs
-- http://habrahabr.ru/post/128704/
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]
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 <- Random.evalRandIO range
return value
where
range = Random.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 <- Monad.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 = 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)
class GeneUtils a where
selectRandom :: RandomGen g => g -> [a] -> [Genome]
produceParents :: [a] -> IO [(Genome, Genome)]
instance GeneUtils Gene where
selectRandom gen genes = Random.evalRand m gen
where
toTuple (Gene g l) = (g, l)
weights = map toTuple genes
m = sequence . repeat . Random.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 -> Maybe.MaybeT IO [(Genome, Genome)]
generateChilds :: a -> Maybe.MaybeT IO [Genome]
findResults :: a -> [Genome]
runEvolution :: a -> Maybe.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 <- Maybe.MaybeT $ do return $ computeGenes pool
pairs <- Trans.lift $ produceParents genes
return $ pairs
generateChilds pool = do
parents <- generateParents pool
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
Monad.guard $ isNothing fitness
return genome
where
gs = genomes pool
runEvolution pool = do
newPool <- Trans.lift $ evolve pool
return $ findResults newPool
where
evolveOne :: GenePool -> Maybe.MaybeT IO GenePool
evolveOne pool = do
Trans.lift $ print pool
childs <- generateChilds pool
return (GenePool childs)
evolve :: GenePool -> IO GenePool
evolve pool = do
maybeNextPool <- Maybe.runMaybeT $ evolveOne pool
case maybeNextPool of
Nothing -> return pool
Just nextPool -> do
pool <- evolve nextPool
return pool
-- run solver
main = do
gs <- Monad.replicateM populationSize generateGenome
results <- Maybe.runMaybeT $ runEvolution (GenePool gs)
print $ results
where
populationSize = 128
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment