diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Alexander Alexeev + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexander Alexeev nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/simple-genetic-algorithm.cabal b/simple-genetic-algorithm.cabal new file mode 100644 --- /dev/null +++ b/simple-genetic-algorithm.cabal @@ -0,0 +1,41 @@ +-- Initial simple-genetic-algorithm.cabal generated by cabal init. For +-- further documentation, see http://haskell.org/cabal/users-guide/ + +name: simple-genetic-algorithm +version: 0.1.0.0 +synopsis: Simple parallel genetic algorithm implementation +description: Simple parallel genetic algorithm implementation +homepage: http://eax.me/haskell-genetic-algorithm/ +license: BSD3 +license-file: LICENSE +author: Alexander Alexeev +maintainer: mail@eax.me +-- copyright: +category: AI +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +source-repository head + type: git + location: git@github.com:afiskon/simple-genetic-algorithm.git + +library + exposed-modules: GA.Simple + ghc-options: -O2 -Wall -fno-warn-missing-signatures + build-depends: base >=4.6 && < 4.7, + random >= 1.0 && < 1.1, + parallel >= 3.2 && < 3.3 + hs-source-dirs: src + default-language: Haskell2010 + +executable ga-sin-example + ghc-options: -O2 -Wall -fno-warn-missing-signatures -threaded -rtsopts + main-is: MainSin.hs + build-depends: base >= 4.6 && < 4.7, + random >= 1.0 && < 1.1, + deepseq >= 1.3 && < 1.4, + parallel >= 3.2 && < 3.3 + hs-source-dirs: src + default-language: Haskell2010 + diff --git a/src/GA/Simple.hs b/src/GA/Simple.hs new file mode 100644 --- /dev/null +++ b/src/GA/Simple.hs @@ -0,0 +1,104 @@ +-- | Simple parallel genetic algorithm implementation. +module GA.Simple ( + Chromosome(..), + runGA, + runGAIO, + zeroGeneration, + nextGeneration + ) where + +import System.Random +import qualified Data.List as L +import Control.Parallel.Strategies + +-- | Chromosome representation +class NFData a => Chromosome a where + -- | Crossover function + crossover :: RandomGen g => g -> a -> a -> ([a],g) + -- | Mutation function + mutation :: RandomGen g => g -> a -> (a,g) + -- | Fitness function. fitness x > fitness y means that x is better than y + fitness :: a -> Double + +-- | Pure GA implementation +runGA :: (RandomGen g, Chromosome a) + => g -- ^ Random number generator + -> Int -- ^ Population size + -> Double -- ^ Mutation probability [0, 1] + -> (g -> (a, g)) -- ^ Random chromosome generator (hint: use closures) + -> (a -> Int -> Bool) -- ^ Stopping criteria, 1st arg - best chromosome, 2nd arg - generation number + -> a -- ^ Best chromosome +runGA gen ps mp rnd stopf = + let (pop, gen') = zeroGeneration gen rnd ps in + runGA' gen' pop ps mp stopf 0 + +runGA' gen pop ps mp stopf gnum = + let best = head pop in + if stopf best gnum + then best + else + let (pop', gen') = nextGeneration gen pop ps mp in + runGA' gen' pop' ps mp stopf (gnum+1) + +-- | Non-pure GA implementation +runGAIO :: Chromosome a + => Int -- ^ Population size + -> Double -- ^ Mutation probability [0, 1] + -> (StdGen -> (a, StdGen)) -- ^ Random chromosome generator (hint: use closures) + -> (a -> Int -> IO Bool) -- ^ Stopping criteria, 1st arg - best chromosome, 2nd arg - generation number + -> IO a -- ^ Best chromosome +runGAIO ps mp rnd stopf = do + gen <- newStdGen + let (pop, gen') = zeroGeneration gen rnd ps + runGAIO' gen' pop ps mp stopf 0 + +runGAIO' gen pop ps mp stopf gnum = do + let best = head pop + stop <- stopf best gnum + if stop + then return best + else do + let (pop', gen') = nextGeneration gen pop ps mp + runGAIO' gen' pop' ps mp stopf (gnum+1) + +-- | Generate zero generation. Use this function only if you are going to implement your own runGA. +zeroGeneration :: (RandomGen g) + => g -- ^ Random number generator + -> (g -> (a, g)) -- ^ Random chromosome generator (hint: use closures) + -> Int -- ^ Population size + -> ([a],g) -- ^ Zero generation and new RNG +zeroGeneration initGen rnd ps = + L.foldl' + (\(xs,gen) _ -> let (c, gen') = rnd gen in ((c:xs),gen')) + ([], initGen) [1..ps] + +-- | Generate next generation (in parallel) using mutation and crossover. +-- Use this function only if you are going to implement your own runGA. +nextGeneration :: (RandomGen g, Chromosome a) + => g -- ^ Random number generator + -> [a] -- ^ Current generation + -> Int -- ^ Population size + -> Double -- ^ Mutation probability + -> ([a], g) -- ^ Next generation ordered by fitness (best - first) and new RNG +nextGeneration gen pop ps mp = + let (gen':gens) = L.unfoldr (Just . split) gen + chunks = L.zip gens $ init $ L.tails pop + results = map (\(g, (x:ys)) -> [ (t, fitness t) | t <- nextGeneration' [ (x, y) | y <- ys ] g mp [] ]) chunks + `using` parList rdeepseq + lst = take ps $ L.sortBy (\(_, fx) (_, fy) -> fy `compare` fx) $ concat results + in ( map fst lst, gen' ) + +nextGeneration' [] _ _ acc = acc +nextGeneration' ((p1,p2):ps) g0 mp acc = + let (children0, g1) = crossover g0 p1 p2 + (children1, g2) = L.foldl' + (\(xs, g) x -> let (x', g') = mutate g x mp in (x':xs, g')) + ([],g1) children0 + in + nextGeneration' ps g2 mp (children1 ++ acc) + +mutate :: (RandomGen g, Chromosome a) => g -> a -> Double -> (a, g) +mutate gen x mp = + let (r, gen') = randomR (0.0, 1.0) gen in + if r <= mp then mutation gen' x + else (x, gen') diff --git a/src/MainSin.hs b/src/MainSin.hs new file mode 100644 --- /dev/null +++ b/src/MainSin.hs @@ -0,0 +1,59 @@ +-- | Example: sin() function interpolation on [0, pi/2] +module Main where + +import GA.Simple +import System.Random +import Text.Printf +import Data.List as L +import Control.DeepSeq + +data SinInt = SinInt [Double] + +instance NFData SinInt where + rnf (SinInt xs) = rnf xs `seq` () + +instance Show SinInt where + show (SinInt []) = "" + show (SinInt (x:xs)) = + let start = printf "%.5f" x + end = concat $ zipWith (\c p -> printf "%+.5f" c ++ "X^" ++ show p) xs [1 :: Int ..] + in start ++ end + +polynomialOrder = 4 :: Int + +err :: SinInt -> Double +err (SinInt xs) = + let f x = snd $ L.foldl' (\(mlt,s) coeff -> (mlt*x, s + coeff*mlt)) (1,0) xs + in maximum [ abs $ sin x - f x | x <- [0.0,0.001 .. pi/2]] + +instance Chromosome SinInt where + crossover g (SinInt xs) (SinInt ys) = + ( [ SinInt (L.zipWith (\x y -> (x+y)/2) xs ys) ], g) + + mutation g (SinInt xs) = + let (idx, g') = randomR (0, length xs - 1) g + (dx, g'') = randomR (-10.0, 10.0) g' + t = xs !! idx + xs' = take idx xs ++ [t + t*dx] ++ drop (idx+1) xs + in (SinInt xs', g'') + + fitness int = + let max_err = 1000.0 in + max_err - (min (err int) max_err) + +randomSinInt gen = + let (lst, gen') = + L.foldl' + (\(xs, g) _ -> let (x, g') = randomR (-10.0,10.0) g in (x:xs,g') ) + ([], gen) [0..polynomialOrder] + in (SinInt lst, gen') + +stopf best gnum = do + let e = err best + putStrLn $ "Generation: " ++ printf "%02d" gnum ++ ", Error: " ++ printf "%.8f" e + return $ e < 0.0002 || gnum > 20 + +main = do + int <- runGAIO 64 0.1 randomSinInt stopf + putStrLn "" + putStrLn $ "Result: " ++ show int