Created
April 4, 2012 06:30
-
-
Save blackwithwhite666/2298992 to your computer and use it in GitHub Desktop.
Solve Diophantine equation with Haskell
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| -- 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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment