hgalib (empty) → 0.1
raw patch · 35 files changed
+1817/−0 lines, 35 filesdep +arraydep +basedep +haskell98setup-changedbinary-added
Dependencies added: array, base, haskell98, mtl
Files
- Chromosome/ANN.hs +142/−0
- Chromosome/Bits.hs +53/−0
- Chromosome/GP.hs +88/−0
- GA.hs +142/−0
- LICENSE +1/−0
- Population/Array.hs +101/−0
- Population/List.hs +81/−0
- README +13/−0
- Setup.lhs +3/−0
- _darcs/format +1/−0
- _darcs/inventory +11/−0
- _darcs/patches/20080819224536-2e7c7-16fca1334987407b252c303d6d18be29e7f74594.gz binary
- _darcs/patches/20080820194518-2e7c7-2c2b981ba8bd66edf4f1853dcaf929c22d7de013.gz binary
- _darcs/patches/20080826060739-2e7c7-cea315b48cddfa35ef09426cc5ecc4b4d1ac8619.gz binary
- _darcs/patches/20080826153840-2e7c7-bfffecbf6d5c3ee694f167da4c0eae6274482c55.gz binary
- _darcs/patches/pending +2/−0
- _darcs/patches/pending.tentative +2/−0
- _darcs/prefs/author +1/−0
- _darcs/prefs/binaries +59/−0
- _darcs/prefs/boring +56/−0
- _darcs/prefs/motd +0/−0
- _darcs/pristine/Chromosome/ANN.hs +142/−0
- _darcs/pristine/Chromosome/Bits.hs +53/−0
- _darcs/pristine/Chromosome/GP.hs +88/−0
- _darcs/pristine/GA.hs +142/−0
- _darcs/pristine/Population/Array.hs +101/−0
- _darcs/pristine/Population/List.hs +81/−0
- _darcs/pristine/examples/ANNTest.hs +70/−0
- _darcs/pristine/examples/BitTest.hs +64/−0
- _darcs/pristine/examples/GPTest.hs +75/−0
- _darcs/tentative_pristine +16/−0
- examples/ANNTest.hs +70/−0
- examples/BitTest.hs +64/−0
- examples/GPTest.hs +75/−0
- hgalib.cabal +20/−0
+ Chromosome/ANN.hs view
@@ -0,0 +1,142 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++-- | Artificial Neural Networks+module Chromosome.ANN (ANN, Layer, Node,+ eval,+ config,+ uniformCross,+ averageCross,+ mutateRandomize,+ mutateShift,+ fitnessMSE,+ averageMSE,+ correctExamples,+ randomANN)+where++import GA+import Control.Monad.State+import List+import Random++-- |An Artificial Neural Network+type ANN = [Layer]+-- |A layer of nodes in an ANN+type Layer = [Node]+-- |A node in an ANN. The head of the list is the bias weight. The tail is the weights for the previous layer+type Node = [Double]++-- User must specify fitness, mutate, and crossover functions+config = ChromosomeConfig {+ fitness = undefined,+ mutate = undefined,+ cross = undefined+ }++-- |Returns the number of examples correct within the tolerance. The examples are a list of tuples of (input, output)+correctExamples :: [([Double],[Double])] -> Double -> ANN -> Double+correctExamples examples tolerance ann =+ fromIntegral $ sum $ map (correctExample ann tolerance) examples++correctExample :: ANN -> Double -> ([Double],[Double]) -> Int+correctExample ann tolerance example =+ numMatching ((<tolerance) . abs) $+ rawError ann example++-- |Computes the fitness based on the mean square error for a list of examples+-- The examples are a list of tuples of (input, output)+fitnessMSE :: [([Double],[Double])] -> ANN -> Double+fitnessMSE examples ann = 1.0 / averageMSE ann examples++-- |Computes the mean square error for a list of examples+-- The examples are a list of tuples of (input, output)+averageMSE :: ANN -> [([Double],[Double])] -> Double+averageMSE ann examples =+ average $ map (mse ann) examples++mse :: ANN -> ([Double],[Double]) -> Double+mse ann examples =+ average $ map (^2) $ rawError ann examples++rawError :: ANN -> ([Double], [Double]) -> [Double]+rawError ann (ins, outs) =+ zipWith (-) outs $ eval ins ann++-- |Mutates an ANN by randomly settings weights to +/- range+mutateRandomize :: Double -> Double -> ANN -> (GAState ANN p) ANN+mutateRandomize rate range ann =+ mapM (mapM (mapM rnd)) ann+ where rnd = randWeight False rate range++-- |Mutates an ANN by randomly shifting weights by +/- range+mutateShift :: Double -> Double -> ANN -> (GAState ANN p) ANN+mutateShift rate range ann =+ mapM (mapM (mapM rnd)) ann+ where rnd = randWeight True rate range++randWeight :: Bool -> Double -> Double -> Double -> (GAState c p) Double+randWeight shiftp rate range weight = do+ test <- gaRand (0.0, 1.0)+ if test > rate+ then return weight+ else do+ delta <- gaRand (-range, range)+ return $ delta + (if shiftp then weight else 0.0)++-- |Crossover between two ANN's by exchanging weights+uniformCross :: ANN -> ANN -> (GAState c p) (ANN,ANN)+uniformCross xsss ysss =+ zipWithM (zipWithM (zipWithM pickRandom)) xsss ysss >>=+ return . unzip . map unzip . map (map unzip)++-- |Crossover between two ANN's by averaging weights+averageCross :: ANN -> ANN -> (GAState c p) (ANN,ANN)+averageCross n1 n2 =+ let retval = zipWith (zipWith (zipWith avg)) n1 n2+ in return (retval, retval)++pickRandom :: a -> a -> (GAState c p) (a,a)+pickRandom x y = do+ test <- gaRand (False, True)+ if test then return (x,y) else return (y,x)++-- |Evaluates an ANN with a given input+eval :: [Double] -> ANN -> [Double]+eval input [] = input+eval input (x:xs) =+ eval (evalLayer input x) xs++evalLayer :: [Double] -> Layer -> [Double]+evalLayer inputs =+ map (evalNode inputs)++evalNode :: [Double] -> Node -> Double+evalNode inputs (bias : weights) =+ sigmoid $ bias + dotProduct inputs weights++-- |Generates a random ANN with a given number of input nodes, a list of number of hidden nodes per layer, and the weight range+randomANN :: Int -> [Int] -> Double -> (GAState c p) ANN+randomANN _ [] _ = return []+randomANN i (l:ls) r = do+ x <- randomLayer i l r+ xs <- randomANN l ls r+ return $ x : xs++randomLayer :: Int -> Int -> Double -> (GAState c p) Layer+randomLayer i o range = replicateM o $ randomNode i range++randomNode :: Int -> Double -> (GAState c p) Node+randomNode i range = replicateM (i+1) $ gaRand (-range,range)++-- Low level utilities+sigmoid :: Double -> Double+sigmoid x = 1.0 / (1.0 + exp (-x))++dotProduct :: [Double] -> [Double] -> Double+dotProduct u v = sum $ zipWith (*) u v++avg x y = (x + y) / 2.0+average xs = sum xs / genericLength xs++numMatching p =+ foldl (\acc x -> if p x then acc + 1 else acc) 0
+ Chromosome/Bits.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++-- | Chromosomes represented as a bit field+module Chromosome.Bits (mutateBits,+ bits2int,+ randomBits,+ pointCross,+ config)+where++import List+import Random+import Control.Monad.State+import GA++-- |The config for a chromosome of a list of bits. User must defined fitness and mutate.+config :: ChromosomeConfig [a] p+config = ChromosomeConfig {+ fitness = undefined,+ mutate = undefined,+ cross = pointCross+}++-- |Single point cross at a random location+pointCross :: [a] -> [a] -> (GAState c p) ([a],[a])+pointCross xs ys = do+ let len = length xs+ point <- gaRand (0, len)+ let (left1, right1) = splitAt point xs+ (left2, right2) = splitAt point ys+ in return $ (left1 ++ right2, left2 ++ right1)++-- |Generates i random bits+randomBits :: Int -> (GAState c p) [Bool]+randomBits i = replicateM i (gaRand (True, False))++-- |Randomly flips fits with a specified probability+mutateBits :: Double -> [Bool] -> (GAState c p) [Bool]+mutateBits mutationRate xs =+ mapM (mutateBit mutationRate) xs+++mutateBit r b = do+ test <- gaRand (0.0, 1.0)+ if test < r+ then return $ not b+ else return b++-- |Converts a list of Bool's to it's integer representation+bits2int :: [Bool] -> Int+bits2int bs =+ sum [ x | (x, b) <- zip _2pwrs bs, b ]+ where _2pwrs = 1 : map (*2) _2pwrs
+ Chromosome/GP.hs view
@@ -0,0 +1,88 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++-- | Genetic Programming as strictly-evaluated s-expressions+module Chromosome.GP (Op (..),+ Node (..),+ mseFitness,+ mutate,+ eval,+ random,+ config)+where++import Array+import qualified GA+import Control.Monad.State+import List++-- The config for the GP chromosome model. mutate, cross, and fitness must be defined.+config = GA.ChromosomeConfig {+ GA.mutate = undefined,+ GA.cross = undefined,+ GA.fitness = undefined+ }++-- |An operator in the syntax tree of the GP+data Op a s = Op {+ -- |The function for evaluating this node+ callback :: ([a] -> State s a),+ -- |The number of children of this node+ arity :: Int,+ -- |The name of the node when shown+ name :: String+ }++instance Show (Op a s) where+ show = name++-- |A node in the syntax tree of the GP+data Node a s = Node (Op a s) [Node a s]++instance Show (Node a s) where+ show (Node o children) =+ if arity o == 0+ then show o+ else "(" ++ (unwords $ show o : map show children) ++ ")"++-- |Calculates fitness based on the mean square error across a list of examples+-- The examples are a list of tuples of (inputs state, correct output)+mseFitness :: (Fractional a) => [(s, a)] -> Node a s -> a+mseFitness examples node =+ 1.0 / (mse node examples + 1.0)++mse :: (Fractional a) => Node a s -> [(s, a)] -> a+mse node examples =+ average $ map (^2) $ map (\(i,o) -> delta node i o) examples++delta node state output =+ output - (evalState (eval node) state)++-- |Statefully evaluates a given GP+eval :: Node a s -> State s a+eval (Node (Op f _ _) ns) =+ mapM eval ns >>= f++-- |Mutates a GP by replacing nodes with random GP's+mutate 0 ops rate tree = error "Attempt to mutate with depth of 0"+mutate d ops rate tree@(Node op children) = do+ test <- GA.gaRand (0.0, 1.0)+ if test >= rate -- No mutation+ then do newChildren <- mapM (mutate (d-1) ops rate) children+ return $ Node op newChildren+ else random d ops++-- |Generates a random GP with a given depth limit+random 0 ops = error "Attempt to create depth 0 tree"+random 1 ops = do+ op <- randomOp $ filter ((==0) . arity) ops+ return $ Node op []+random d ops = do+ op <- randomOp ops+ children <- replicateM (arity op) $ random (d-1) ops+ return $ Node op children++randomOp ops =+ GA.gaRand (0,length ops - 1) >>=+ return . (ops !!)++average xs = sum xs / genericLength xs
+ GA.hs view
@@ -0,0 +1,142 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++-- | Genetic Algorithms+module GA (Config (..),+ PopulationConfig (..),+ ChromosomeConfig (..),+ defaultConfig,+ GAState,+ bestChromosome,+ gaRand,+ run,+ rouletteM,+ mutateM,+ crossM,+ tournamentM,+ isDone)+where++import Maybe+import Random+import Control.Monad.State++type GAState c p = State (Config c p)++data Config c p = Config {+ -- |The config for the chromosome model+ cConfig :: ChromosomeConfig c p,+ -- |The config for the population model+ pConfig :: PopulationConfig c p,+ -- |The function that transforms a population into the next generation+ newPopulation :: p -> (GAState c p) p,+ -- |The fitness at which to stop the GA+ maxFitness :: Maybe Double,+ -- |The generation at which to stop the GA+ maxGeneration :: Maybe Int,+ -- |The number of generations elapsed. defaultConfig sets this to 0+ currentGeneration :: Int,+ -- |The random number generator+ gen :: StdGen+ }++data ChromosomeConfig c p = ChromosomeConfig {+ -- |The fitness function for the chromosome model+ fitness :: c -> Double,+ -- |The mutation operator for the chromosome model+ mutate :: c -> (GAState c p) c,+ -- |The crossover operator for the chromosome model+ cross :: c -> c -> (GAState c p) (c,c)+ }++data PopulationConfig c p = PopulationConfig {+ bestChromosomePop :: p -> (GAState c p) c,+ roulettePop :: p -> (GAState c p) p,+ tournamentPop :: p -> (GAState c p) p,+ applyCrossoverPop :: p -> (GAState c p) p,+ applyMutationPop :: p -> (GAState c p) p+ }+-- |defaultConfig acts as a blank slate for genetic algorithms.+-- cConfig, pConfig, gen, and maxFitness or maxGeneration must be defined+defaultConfig :: Config c p+defaultConfig = Config {+ cConfig = undefined,+ pConfig = undefined,+ newPopulation = undefined,+ maxFitness = Nothing,+ maxGeneration = Nothing,+ currentGeneration = 0,+ gen = undefined+ }++-- |Wrapper function which returns the best chromosome of a population+bestChromosome :: p -> (GAState c p) c+bestChromosome pop = do+ config <- get+ bestChromosomePop (pConfig config) pop++-- |Wrapper function which returns the highest-fitness member of a population+highestFitness :: p -> (GAState c p) Double+highestFitness pop = do+ fitFunc <- (fitness . cConfig) `liftM` get+ best <- bestChromosome pop+ return $ fitFunc best++-- |A wrapper function for use in newPopulation for roulette selection+rouletteM :: p -> (GAState c p) p+rouletteM pop =+ (roulettePop . pConfig) `liftM` get >>= ($pop)++-- |A wrapper function for use in newPopulation for tournament selection+tournamentM :: p -> (GAState c p) p+tournamentM pop =+ (tournamentPop . pConfig) `liftM` get >>= ($pop)++-- |A wrapper function for use in newPopulation for mutating the population+mutateM :: p -> (GAState c p) p+mutateM pop = do+ (applyMutationPop . pConfig) `liftM` get >>= ($pop)++-- |A wrapper function for use in newPopulation for applying crossover to the population+crossM :: p -> (GAState c p) p+crossM pop =+ (applyCrossoverPop . pConfig) `liftM` get >>= ($pop)++newPopulationM :: p -> (GAState c p) p+newPopulationM pop =+ incGA >> newPopulation `liftM` get >>= ($pop)++incGA :: (GAState c p) ()+incGA = modify (\c@Config { currentGeneration = g} ->+ c { currentGeneration = g + 1})++untilM :: (Monad m) => (a -> m Bool) -> (a -> m a) -> a -> m a+untilM p f x = do+ test <- p x+ if test + then return x+ else f x >>= untilM p f++-- |Runs the specified GA config until the termination condition is reached+run :: p -> (GAState c p) p+run = untilM isDone newPopulationM++-- |Returns true if the given population satisfies the termination condition for the GA config+isDone :: p -> (GAState c p) Bool+isDone population = do+ c <- get+ f <- highestFitness population+ let generationsDone =+ maybe False (<(currentGeneration c)) $ maxGeneration c+ let fitnessDone =+ maybe False (>f) $ maxFitness c+ return $ generationsDone || fitnessDone++-- |Generates a random number which updating the random number generator for the config+gaRand :: (Random a) =>+ (a,a) -> (GAState c p) a+gaRand range = do+ config <- get+ let g = gen config+ let (x, g') = randomR range g+ put $ config { gen = g' }+ return x
+ LICENSE view
@@ -0,0 +1,1 @@+Copyleft 2008. All rights reversed.
+ Population/Array.hs view
@@ -0,0 +1,101 @@++-- | Populations represented as a diff array of chromosomes+module Population.Array (config, fromList)+where++import GA++import Data.Array.Diff+import Control.Monad+import Control.Monad.State+import List++-- |The type used to represent population arrays; is a diff array.+type PArray c = DiffArray Int c++-- |Population config for arrays+config :: PopulationConfig c (PArray c)+config = PopulationConfig {+ bestChromosomePop = bestChromosomeArray,+ roulettePop = rouletteArray,+ tournamentPop = tournamentArray,+ applyCrossoverPop = crossoverArray,+ applyMutationPop = mutateArray+}++--yipee+tournamentArray :: PArray c -> (GAState c p) (PArray c)+tournamentArray arr = do+ f <- (fitness . cConfig) `liftM` get+ let augument c = (c, f c)+ let augArr = amap augument arr+ aforM arr $ \_ -> do+ index1 <- gaRand $ bounds arr+ index2 <- gaRand $ bounds arr+ let chrom1 = augArr ! index1+ let chrom2 = augArr ! index2+ if snd chrom1 > snd chrom2+ then return $ fst chrom1+ else return $ fst chrom2++mutateArray :: PArray c -> (GAState c (PArray c)) (PArray c)+mutateArray arr =+ (mutate . cConfig) `liftM` get >>= flip amapM arr++crossoverArray arr = do+ c <- (cross . cConfig) `liftM` get+ crossoverArray' c arr $ fst $ bounds arr++crossoverArray' cross arr index =+ let lastIndex = snd $ bounds arr in+ if index > lastIndex+ then return arr+ else+ let p1 = arr ! index+ p2 = arr ! (index + 1)+ in do (c1, c2) <- cross p1 p2+ let newArr = arr // [(index, c1), (index + 1, c2)]+ crossoverArray' cross newArr (index + 2)++bestChromosomeArray :: PArray c -> (GAState c p) c+bestChromosomeArray arr = do+ f <- (fitness . cConfig) `liftM` get+ let cmp x y | f x > f y = x+ | otherwise = y+ return $ afoldl1 cmp arr+++rouletteArray :: PArray c -> (GAState c p) (PArray c)+rouletteArray arr = do+ f <- (fitness . cConfig) `liftM` get+ let totalFitness = (afoldl (\fit c -> fit + f c) 0.0 arr) :: Double+ let augument chrom = (chrom, (f chrom) / totalFitness)+ let augArr = amap augument arr+ aforM arr $ \_ ->+ selectDistribution augArr 0.0 $ fst $ bounds arr++selectDistribution :: PArray (c, Double) -> Double -> Int -> (GAState c p) c+selectDistribution arr acc index =+ let lastIndex = snd $ bounds arr in+ if index == lastIndex+ then return $ fst $ arr ! lastIndex+ else do+ let (chrom, fit) = arr ! index+ test <- gaRand (0.0, 1.0)+ if test < fit / (1 - acc)+ then return chrom+ else selectDistribution arr (fit + acc) (index + 1)++-- |Converts a list to an array+fromList xs = listArray (0, length xs - 1) xs++amapM p arr =+ listArray (bounds arr) `liftM` mapM p (elems arr)++aforM arr p = amapM p arr+ +afoldl p seed arr =+ foldl p seed $ elems arr++afoldl1 p arr =+ foldl1 p $ elems arr
+ Population/List.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++-- | Populations represented as a list of chromosomes+-- Arrays are recommended instead for performance reasons.+module Population.List (config)+where++import GA++import Control.Monad+import Control.Monad.State+import Random+import List++-- |Config for use of lists as the population model. Lists are deprecated in favor of arrays.+config :: PopulationConfig c [c]+config = PopulationConfig {+ bestChromosomePop = bestChromosomeList,+ roulettePop = rouletteList,+ tournamentPop = tournamentList,+ applyCrossoverPop = crossoverList,+ applyMutationPop = mutateList+ }++-- Warning: shit performance for tournamentList :/ O(n^2) afaict+-- Moral o Story: Lists suck, but arrays are fugly ;_;+tournamentList :: [c] -> (GAState c [c]) [c]+tournamentList xs = do+ f <- (fitness . cConfig) `liftM` get+ let len = length xs+ let augChroms = map (\c -> (c, f c)) xs+ forM xs $ \_ -> do+ index1 <- gaRand (0, len - 1)+ index2 <- gaRand (0, len - 1)+ let test1 = augChroms !! index1+ let test2 = augChroms !! index2+ if snd test1 > snd test2+ then return $ fst test1+ else return $ fst test2++crossoverList :: [c] -> (GAState c [c]) [c]+crossoverList [] = return []+crossoverList [x] = return [x]+crossoverList (x:y:xs) = do+ c <- (cross . cConfig) `liftM` get+ (offspring1,offspring2) <- c x y+ rest <- crossoverList xs+ return $ offspring1 : offspring2 : rest++mutateList :: [c] -> (GAState c [c]) [c]+mutateList cs =+ (mutate . cConfig) `liftM` get >>= forM cs++rouletteList :: [c] -> (GAState c [c]) [c]+rouletteList cs = do+ f <- (fitness . cConfig) `liftM` get+ let fs = map f cs+ let total = sum fs+ let probs = map (/total) fs+ let augumentedChromosomes = zip cs probs+ forM cs $+ \_ -> selectDistribution augumentedChromosomes+++bestChromosomeList :: [c] -> (GAState c [c]) c+bestChromosomeList cs = do+ f <- (fitness . cConfig) `liftM` get+ let compareChromosomes x y =+ compare (f x) (f y)+ return $ maximumBy compareChromosomes cs+++selectDistribution :: [(a, Double)] -> (GAState c p) a+selectDistribution xs =+ select 0.0 xs+ where select _ ((a,p):[]) = return a+ select acc ((a,p):xs) = do+ test <- gaRand (0,1.0)+ if test < p / (1 - acc)+ then return a+ else select (p + acc) xs
+ README view
@@ -0,0 +1,13 @@+See examples/. It should get you started.+The source code is haddock-ready. Run:++runhaskell Setup.hs configure+runhaskell Setup.hs haddock++Note you need haddock version 2.++Please send comments, patches, etc to:++ellisk@catlin.edu++Thank you so much for using hgalib.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ _darcs/format view
@@ -0,0 +1,1 @@+darcs-1.0
+ _darcs/inventory view
@@ -0,0 +1,11 @@++[Genesis+ellisk@catlin.edu**20080819224536] +[examples+ellisk@catlin.edu**20080820194518] +[0.1 final+ellisk@catlin.edu**20080826060739+ Got everything ready for the 0.1 release+] +[Improved GP example+ellisk@catlin.edu**20080826153840]
+ _darcs/patches/20080819224536-2e7c7-16fca1334987407b252c303d6d18be29e7f74594.gz view
binary file changed (absent → 5220 bytes)
+ _darcs/patches/20080820194518-2e7c7-2c2b981ba8bd66edf4f1853dcaf929c22d7de013.gz view
binary file changed (absent → 1860 bytes)
+ _darcs/patches/20080826060739-2e7c7-cea315b48cddfa35ef09426cc5ecc4b4d1ac8619.gz view
binary file changed (absent → 710 bytes)
+ _darcs/patches/20080826153840-2e7c7-bfffecbf6d5c3ee694f167da4c0eae6274482c55.gz view
binary file changed (absent → 360 bytes)
+ _darcs/patches/pending view
@@ -0,0 +1,2 @@+{+}
+ _darcs/patches/pending.tentative view
@@ -0,0 +1,2 @@+{+}
+ _darcs/prefs/author view
@@ -0,0 +1,1 @@+ellisk@catlin.edu
+ _darcs/prefs/binaries view
@@ -0,0 +1,59 @@+# Binary file regexps:+\.png$+\.PNG$+\.gz$+\.GZ$+\.pdf$+\.PDF$+\.jpg$+\.JPG$+\.jpeg$+\.JPEG$+\.gif$+\.GIF$+\.tif$+\.TIF$+\.tiff$+\.TIFF$+\.pnm$+\.PNM$+\.pbm$+\.PBM$+\.pgm$+\.PGM$+\.ppm$+\.PPM$+\.bmp$+\.BMP$+\.mng$+\.MNG$+\.tar$+\.TAR$+\.bz2$+\.BZ2$+\.z$+\.Z$+\.zip$+\.ZIP$+\.jar$+\.JAR$+\.so$+\.SO$+\.a$+\.A$+\.tgz$+\.TGZ$+\.mpg$+\.MPG$+\.mpeg$+\.MPEG$+\.iso$+\.ISO$+\.exe$+\.EXE$+\.doc$+\.DOC$+\.elc$+\.ELC$+\.pyc$+\.PYC$
+ _darcs/prefs/boring view
@@ -0,0 +1,56 @@+# Boring file regexps:+\.hi$+\.hi-boot$+\.o-boot$+\.o$+\.o\.cmd$+# *.ko files aren't boring by default because they might+# be Korean translations rather than kernel modules.+# \.ko$+\.ko\.cmd$+\.mod\.c$+(^|/)\.tmp_versions($|/)+(^|/)CVS($|/)+\.cvsignore$+^\.#+(^|/)RCS($|/)+,v$+(^|/)\.svn($|/)+(^|/)\.hg($|/)+\.bzr$+(^|/)SCCS($|/)+~$+(^|/)_darcs($|/)+\.bak$+\.BAK$+\.orig$+\.rej$+(^|/)vssver\.scc$+\.swp$+(^|/)MT($|/)+(^|/)\{arch\}($|/)+(^|/).arch-ids($|/)+(^|/),+\.prof$+(^|/)\.DS_Store$+(^|/)BitKeeper($|/)+(^|/)ChangeSet($|/)+\.py[co]$+\.elc$+\.class$+\#+(^|/)Thumbs\.db$+(^|/)autom4te\.cache($|/)+(^|/)config\.(log|status)$+^\.depend$+(^|/)(tags|TAGS)$+#(^|/)\.[^/]+(^|/|\.)core$+\.(obj|a|exe|so|lo|la)$+^\.darcs-temp-mail$+-darcs-backup[[:digit:]]+$+\.(fas|fasl|sparcf|x86f)$+\.part$+(^|/)\.waf-[[:digit:].]+-[[:digit:]]+($|/)+(^|/)\.lock-wscript$+^\.darcs-temp-mail$
+ _darcs/prefs/motd view
+ _darcs/pristine/Chromosome/ANN.hs view
@@ -0,0 +1,142 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++-- | Artificial Neural Networks+module Chromosome.ANN (ANN, Layer, Node,+ eval,+ config,+ uniformCross,+ averageCross,+ mutateRandomize,+ mutateShift,+ fitnessMSE,+ averageMSE,+ correctExamples,+ randomANN)+where++import GA+import Control.Monad.State+import List+import Random++-- |An Artificial Neural Network+type ANN = [Layer]+-- |A layer of nodes in an ANN+type Layer = [Node]+-- |A node in an ANN. The head of the list is the bias weight. The tail is the weights for the previous layer+type Node = [Double]++-- User must specify fitness, mutate, and crossover functions+config = ChromosomeConfig {+ fitness = undefined,+ mutate = undefined,+ cross = undefined+ }++-- |Returns the number of examples correct within the tolerance. The examples are a list of tuples of (input, output)+correctExamples :: [([Double],[Double])] -> Double -> ANN -> Double+correctExamples examples tolerance ann =+ fromIntegral $ sum $ map (correctExample ann tolerance) examples++correctExample :: ANN -> Double -> ([Double],[Double]) -> Int+correctExample ann tolerance example =+ numMatching ((<tolerance) . abs) $+ rawError ann example++-- |Computes the fitness based on the mean square error for a list of examples+-- The examples are a list of tuples of (input, output)+fitnessMSE :: [([Double],[Double])] -> ANN -> Double+fitnessMSE examples ann = 1.0 / averageMSE ann examples++-- |Computes the mean square error for a list of examples+-- The examples are a list of tuples of (input, output)+averageMSE :: ANN -> [([Double],[Double])] -> Double+averageMSE ann examples =+ average $ map (mse ann) examples++mse :: ANN -> ([Double],[Double]) -> Double+mse ann examples =+ average $ map (^2) $ rawError ann examples++rawError :: ANN -> ([Double], [Double]) -> [Double]+rawError ann (ins, outs) =+ zipWith (-) outs $ eval ins ann++-- |Mutates an ANN by randomly settings weights to +/- range+mutateRandomize :: Double -> Double -> ANN -> (GAState ANN p) ANN+mutateRandomize rate range ann =+ mapM (mapM (mapM rnd)) ann+ where rnd = randWeight False rate range++-- |Mutates an ANN by randomly shifting weights by +/- range+mutateShift :: Double -> Double -> ANN -> (GAState ANN p) ANN+mutateShift rate range ann =+ mapM (mapM (mapM rnd)) ann+ where rnd = randWeight True rate range++randWeight :: Bool -> Double -> Double -> Double -> (GAState c p) Double+randWeight shiftp rate range weight = do+ test <- gaRand (0.0, 1.0)+ if test > rate+ then return weight+ else do+ delta <- gaRand (-range, range)+ return $ delta + (if shiftp then weight else 0.0)++-- |Crossover between two ANN's by exchanging weights+uniformCross :: ANN -> ANN -> (GAState c p) (ANN,ANN)+uniformCross xsss ysss =+ zipWithM (zipWithM (zipWithM pickRandom)) xsss ysss >>=+ return . unzip . map unzip . map (map unzip)++-- |Crossover between two ANN's by averaging weights+averageCross :: ANN -> ANN -> (GAState c p) (ANN,ANN)+averageCross n1 n2 =+ let retval = zipWith (zipWith (zipWith avg)) n1 n2+ in return (retval, retval)++pickRandom :: a -> a -> (GAState c p) (a,a)+pickRandom x y = do+ test <- gaRand (False, True)+ if test then return (x,y) else return (y,x)++-- |Evaluates an ANN with a given input+eval :: [Double] -> ANN -> [Double]+eval input [] = input+eval input (x:xs) =+ eval (evalLayer input x) xs++evalLayer :: [Double] -> Layer -> [Double]+evalLayer inputs =+ map (evalNode inputs)++evalNode :: [Double] -> Node -> Double+evalNode inputs (bias : weights) =+ sigmoid $ bias + dotProduct inputs weights++-- |Generates a random ANN with a given number of input nodes, a list of number of hidden nodes per layer, and the weight range+randomANN :: Int -> [Int] -> Double -> (GAState c p) ANN+randomANN _ [] _ = return []+randomANN i (l:ls) r = do+ x <- randomLayer i l r+ xs <- randomANN l ls r+ return $ x : xs++randomLayer :: Int -> Int -> Double -> (GAState c p) Layer+randomLayer i o range = replicateM o $ randomNode i range++randomNode :: Int -> Double -> (GAState c p) Node+randomNode i range = replicateM (i+1) $ gaRand (-range,range)++-- Low level utilities+sigmoid :: Double -> Double+sigmoid x = 1.0 / (1.0 + exp (-x))++dotProduct :: [Double] -> [Double] -> Double+dotProduct u v = sum $ zipWith (*) u v++avg x y = (x + y) / 2.0+average xs = sum xs / genericLength xs++numMatching p =+ foldl (\acc x -> if p x then acc + 1 else acc) 0
+ _darcs/pristine/Chromosome/Bits.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++-- | Chromosomes represented as a bit field+module Chromosome.Bits (mutateBits,+ bits2int,+ randomBits,+ pointCross,+ config)+where++import List+import Random+import Control.Monad.State+import GA++-- |The config for a chromosome of a list of bits. User must defined fitness and mutate.+config :: ChromosomeConfig [a] p+config = ChromosomeConfig {+ fitness = undefined,+ mutate = undefined,+ cross = pointCross+}++-- |Single point cross at a random location+pointCross :: [a] -> [a] -> (GAState c p) ([a],[a])+pointCross xs ys = do+ let len = length xs+ point <- gaRand (0, len)+ let (left1, right1) = splitAt point xs+ (left2, right2) = splitAt point ys+ in return $ (left1 ++ right2, left2 ++ right1)++-- |Generates i random bits+randomBits :: Int -> (GAState c p) [Bool]+randomBits i = replicateM i (gaRand (True, False))++-- |Randomly flips fits with a specified probability+mutateBits :: Double -> [Bool] -> (GAState c p) [Bool]+mutateBits mutationRate xs =+ mapM (mutateBit mutationRate) xs+++mutateBit r b = do+ test <- gaRand (0.0, 1.0)+ if test < r+ then return $ not b+ else return b++-- |Converts a list of Bool's to it's integer representation+bits2int :: [Bool] -> Int+bits2int bs =+ sum [ x | (x, b) <- zip _2pwrs bs, b ]+ where _2pwrs = 1 : map (*2) _2pwrs
+ _darcs/pristine/Chromosome/GP.hs view
@@ -0,0 +1,88 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++-- | Genetic Programming as strictly-evaluated s-expressions+module Chromosome.GP (Op (..),+ Node (..),+ mseFitness,+ mutate,+ eval,+ random,+ config)+where++import Array+import qualified GA+import Control.Monad.State+import List++-- The config for the GP chromosome model. mutate, cross, and fitness must be defined.+config = GA.ChromosomeConfig {+ GA.mutate = undefined,+ GA.cross = undefined,+ GA.fitness = undefined+ }++-- |An operator in the syntax tree of the GP+data Op a s = Op {+ -- |The function for evaluating this node+ callback :: ([a] -> State s a),+ -- |The number of children of this node+ arity :: Int,+ -- |The name of the node when shown+ name :: String+ }++instance Show (Op a s) where+ show = name++-- |A node in the syntax tree of the GP+data Node a s = Node (Op a s) [Node a s]++instance Show (Node a s) where+ show (Node o children) =+ if arity o == 0+ then show o+ else "(" ++ (unwords $ show o : map show children) ++ ")"++-- |Calculates fitness based on the mean square error across a list of examples+-- The examples are a list of tuples of (inputs state, correct output)+mseFitness :: (Fractional a) => [(s, a)] -> Node a s -> a+mseFitness examples node =+ 1.0 / (mse node examples + 1.0)++mse :: (Fractional a) => Node a s -> [(s, a)] -> a+mse node examples =+ average $ map (^2) $ map (\(i,o) -> delta node i o) examples++delta node state output =+ output - (evalState (eval node) state)++-- |Statefully evaluates a given GP+eval :: Node a s -> State s a+eval (Node (Op f _ _) ns) =+ mapM eval ns >>= f++-- |Mutates a GP by replacing nodes with random GP's+mutate 0 ops rate tree = error "Attempt to mutate with depth of 0"+mutate d ops rate tree@(Node op children) = do+ test <- GA.gaRand (0.0, 1.0)+ if test >= rate -- No mutation+ then do newChildren <- mapM (mutate (d-1) ops rate) children+ return $ Node op newChildren+ else random d ops++-- |Generates a random GP with a given depth limit+random 0 ops = error "Attempt to create depth 0 tree"+random 1 ops = do+ op <- randomOp $ filter ((==0) . arity) ops+ return $ Node op []+random d ops = do+ op <- randomOp ops+ children <- replicateM (arity op) $ random (d-1) ops+ return $ Node op children++randomOp ops =+ GA.gaRand (0,length ops - 1) >>=+ return . (ops !!)++average xs = sum xs / genericLength xs
+ _darcs/pristine/GA.hs view
@@ -0,0 +1,142 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++-- | Genetic Algorithms+module GA (Config (..),+ PopulationConfig (..),+ ChromosomeConfig (..),+ defaultConfig,+ GAState,+ bestChromosome,+ gaRand,+ run,+ rouletteM,+ mutateM,+ crossM,+ tournamentM,+ isDone)+where++import Maybe+import Random+import Control.Monad.State++type GAState c p = State (Config c p)++data Config c p = Config {+ -- |The config for the chromosome model+ cConfig :: ChromosomeConfig c p,+ -- |The config for the population model+ pConfig :: PopulationConfig c p,+ -- |The function that transforms a population into the next generation+ newPopulation :: p -> (GAState c p) p,+ -- |The fitness at which to stop the GA+ maxFitness :: Maybe Double,+ -- |The generation at which to stop the GA+ maxGeneration :: Maybe Int,+ -- |The number of generations elapsed. defaultConfig sets this to 0+ currentGeneration :: Int,+ -- |The random number generator+ gen :: StdGen+ }++data ChromosomeConfig c p = ChromosomeConfig {+ -- |The fitness function for the chromosome model+ fitness :: c -> Double,+ -- |The mutation operator for the chromosome model+ mutate :: c -> (GAState c p) c,+ -- |The crossover operator for the chromosome model+ cross :: c -> c -> (GAState c p) (c,c)+ }++data PopulationConfig c p = PopulationConfig {+ bestChromosomePop :: p -> (GAState c p) c,+ roulettePop :: p -> (GAState c p) p,+ tournamentPop :: p -> (GAState c p) p,+ applyCrossoverPop :: p -> (GAState c p) p,+ applyMutationPop :: p -> (GAState c p) p+ }+-- |defaultConfig acts as a blank slate for genetic algorithms.+-- cConfig, pConfig, gen, and maxFitness or maxGeneration must be defined+defaultConfig :: Config c p+defaultConfig = Config {+ cConfig = undefined,+ pConfig = undefined,+ newPopulation = undefined,+ maxFitness = Nothing,+ maxGeneration = Nothing,+ currentGeneration = 0,+ gen = undefined+ }++-- |Wrapper function which returns the best chromosome of a population+bestChromosome :: p -> (GAState c p) c+bestChromosome pop = do+ config <- get+ bestChromosomePop (pConfig config) pop++-- |Wrapper function which returns the highest-fitness member of a population+highestFitness :: p -> (GAState c p) Double+highestFitness pop = do+ fitFunc <- (fitness . cConfig) `liftM` get+ best <- bestChromosome pop+ return $ fitFunc best++-- |A wrapper function for use in newPopulation for roulette selection+rouletteM :: p -> (GAState c p) p+rouletteM pop =+ (roulettePop . pConfig) `liftM` get >>= ($pop)++-- |A wrapper function for use in newPopulation for tournament selection+tournamentM :: p -> (GAState c p) p+tournamentM pop =+ (tournamentPop . pConfig) `liftM` get >>= ($pop)++-- |A wrapper function for use in newPopulation for mutating the population+mutateM :: p -> (GAState c p) p+mutateM pop = do+ (applyMutationPop . pConfig) `liftM` get >>= ($pop)++-- |A wrapper function for use in newPopulation for applying crossover to the population+crossM :: p -> (GAState c p) p+crossM pop =+ (applyCrossoverPop . pConfig) `liftM` get >>= ($pop)++newPopulationM :: p -> (GAState c p) p+newPopulationM pop =+ incGA >> newPopulation `liftM` get >>= ($pop)++incGA :: (GAState c p) ()+incGA = modify (\c@Config { currentGeneration = g} ->+ c { currentGeneration = g + 1})++untilM :: (Monad m) => (a -> m Bool) -> (a -> m a) -> a -> m a+untilM p f x = do+ test <- p x+ if test + then return x+ else f x >>= untilM p f++-- |Runs the specified GA config until the termination condition is reached+run :: p -> (GAState c p) p+run = untilM isDone newPopulationM++-- |Returns true if the given population satisfies the termination condition for the GA config+isDone :: p -> (GAState c p) Bool+isDone population = do+ c <- get+ f <- highestFitness population+ let generationsDone =+ maybe False (<(currentGeneration c)) $ maxGeneration c+ let fitnessDone =+ maybe False (>f) $ maxFitness c+ return $ generationsDone || fitnessDone++-- |Generates a random number which updating the random number generator for the config+gaRand :: (Random a) =>+ (a,a) -> (GAState c p) a+gaRand range = do+ config <- get+ let g = gen config+ let (x, g') = randomR range g+ put $ config { gen = g' }+ return x
+ _darcs/pristine/Population/Array.hs view
@@ -0,0 +1,101 @@++-- | Populations represented as a diff array of chromosomes+module Population.Array (config, fromList)+where++import GA++import Data.Array.Diff+import Control.Monad+import Control.Monad.State+import List++-- |The type used to represent population arrays; is a diff array.+type PArray c = DiffArray Int c++-- |Population config for arrays+config :: PopulationConfig c (PArray c)+config = PopulationConfig {+ bestChromosomePop = bestChromosomeArray,+ roulettePop = rouletteArray,+ tournamentPop = tournamentArray,+ applyCrossoverPop = crossoverArray,+ applyMutationPop = mutateArray+}++--yipee+tournamentArray :: PArray c -> (GAState c p) (PArray c)+tournamentArray arr = do+ f <- (fitness . cConfig) `liftM` get+ let augument c = (c, f c)+ let augArr = amap augument arr+ aforM arr $ \_ -> do+ index1 <- gaRand $ bounds arr+ index2 <- gaRand $ bounds arr+ let chrom1 = augArr ! index1+ let chrom2 = augArr ! index2+ if snd chrom1 > snd chrom2+ then return $ fst chrom1+ else return $ fst chrom2++mutateArray :: PArray c -> (GAState c (PArray c)) (PArray c)+mutateArray arr =+ (mutate . cConfig) `liftM` get >>= flip amapM arr++crossoverArray arr = do+ c <- (cross . cConfig) `liftM` get+ crossoverArray' c arr $ fst $ bounds arr++crossoverArray' cross arr index =+ let lastIndex = snd $ bounds arr in+ if index > lastIndex+ then return arr+ else+ let p1 = arr ! index+ p2 = arr ! (index + 1)+ in do (c1, c2) <- cross p1 p2+ let newArr = arr // [(index, c1), (index + 1, c2)]+ crossoverArray' cross newArr (index + 2)++bestChromosomeArray :: PArray c -> (GAState c p) c+bestChromosomeArray arr = do+ f <- (fitness . cConfig) `liftM` get+ let cmp x y | f x > f y = x+ | otherwise = y+ return $ afoldl1 cmp arr+++rouletteArray :: PArray c -> (GAState c p) (PArray c)+rouletteArray arr = do+ f <- (fitness . cConfig) `liftM` get+ let totalFitness = (afoldl (\fit c -> fit + f c) 0.0 arr) :: Double+ let augument chrom = (chrom, (f chrom) / totalFitness)+ let augArr = amap augument arr+ aforM arr $ \_ ->+ selectDistribution augArr 0.0 $ fst $ bounds arr++selectDistribution :: PArray (c, Double) -> Double -> Int -> (GAState c p) c+selectDistribution arr acc index =+ let lastIndex = snd $ bounds arr in+ if index == lastIndex+ then return $ fst $ arr ! lastIndex+ else do+ let (chrom, fit) = arr ! index+ test <- gaRand (0.0, 1.0)+ if test < fit / (1 - acc)+ then return chrom+ else selectDistribution arr (fit + acc) (index + 1)++-- |Converts a list to an array+fromList xs = listArray (0, length xs - 1) xs++amapM p arr =+ listArray (bounds arr) `liftM` mapM p (elems arr)++aforM arr p = amapM p arr+ +afoldl p seed arr =+ foldl p seed $ elems arr++afoldl1 p arr =+ foldl1 p $ elems arr
+ _darcs/pristine/Population/List.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++-- | Populations represented as a list of chromosomes+-- Arrays are recommended instead for performance reasons.+module Population.List (config)+where++import GA++import Control.Monad+import Control.Monad.State+import Random+import List++-- |Config for use of lists as the population model. Lists are deprecated in favor of arrays.+config :: PopulationConfig c [c]+config = PopulationConfig {+ bestChromosomePop = bestChromosomeList,+ roulettePop = rouletteList,+ tournamentPop = tournamentList,+ applyCrossoverPop = crossoverList,+ applyMutationPop = mutateList+ }++-- Warning: shit performance for tournamentList :/ O(n^2) afaict+-- Moral o Story: Lists suck, but arrays are fugly ;_;+tournamentList :: [c] -> (GAState c [c]) [c]+tournamentList xs = do+ f <- (fitness . cConfig) `liftM` get+ let len = length xs+ let augChroms = map (\c -> (c, f c)) xs+ forM xs $ \_ -> do+ index1 <- gaRand (0, len - 1)+ index2 <- gaRand (0, len - 1)+ let test1 = augChroms !! index1+ let test2 = augChroms !! index2+ if snd test1 > snd test2+ then return $ fst test1+ else return $ fst test2++crossoverList :: [c] -> (GAState c [c]) [c]+crossoverList [] = return []+crossoverList [x] = return [x]+crossoverList (x:y:xs) = do+ c <- (cross . cConfig) `liftM` get+ (offspring1,offspring2) <- c x y+ rest <- crossoverList xs+ return $ offspring1 : offspring2 : rest++mutateList :: [c] -> (GAState c [c]) [c]+mutateList cs =+ (mutate . cConfig) `liftM` get >>= forM cs++rouletteList :: [c] -> (GAState c [c]) [c]+rouletteList cs = do+ f <- (fitness . cConfig) `liftM` get+ let fs = map f cs+ let total = sum fs+ let probs = map (/total) fs+ let augumentedChromosomes = zip cs probs+ forM cs $+ \_ -> selectDistribution augumentedChromosomes+++bestChromosomeList :: [c] -> (GAState c [c]) c+bestChromosomeList cs = do+ f <- (fitness . cConfig) `liftM` get+ let compareChromosomes x y =+ compare (f x) (f y)+ return $ maximumBy compareChromosomes cs+++selectDistribution :: [(a, Double)] -> (GAState c p) a+selectDistribution xs =+ select 0.0 xs+ where select _ ((a,p):[]) = return a+ select acc ((a,p):xs) = do+ test <- gaRand (0,1.0)+ if test < p / (1 - acc)+ then return a+ else select (p + acc) xs
+ _darcs/pristine/examples/ANNTest.hs view
@@ -0,0 +1,70 @@+import GA+import qualified Population.List as L+import Random+import Control.Monad.State+import List+import qualified Chromosome.ANN as ANN+import Control.Monad+++-- This function takes a population ("pop"), then mutates it, then applies roulette selection+mynewPopulation pop = mutateM pop >>= rouletteM+++myconfig = defaultConfig {+ -- cConfig configures the chromosome model and the genetic operators+ cConfig = ANN.config {+ fitness = ANN.fitnessMSE xorExamples,+ mutate = ANN.mutateShift 0.1 1.0,+ cross = ANN.uniformCross+ },++ -- The population will be represented as a list+ pConfig = L.config,++ -- To generate the next population, mynewPopulation will be called+ newPopulation = mynewPopulation,++ -- Stop after 1000 generations+ maxGeneration = Just 1000,++ -- Initialize the random number generator to 42+ -- 42 is chosen for obvious reasons+ gen = mkStdGen 42+ }++-- Create an initial population of 20 ANN's+-- Each will have 2 inputs and two hidden layers of [2,1] nodes, respectively+-- The weights will be randomly initialized to +/- 2.0+initPop = replicateM 20 $ ANN.randomANN 2 [2,1] 2.0++-- The examples are a list of (in, out)+xorExamples =+ zip xorIn xorOut+ where xorIn = [[0.0,0.0], [1.0,1.0], [1.0,0.0], [0.0,1.0]]+ xorOut = [[0.0], [0.0], [1.0], [1.0]]++getBest = do+ pop <- initPop+ + -- Grab the best chromosome at the start for comparision+ before <- bestChromosome pop+ + -- Evaluation of the GA+ answer <- run pop+ + -- Find the new best chromosome after running the GA+ after <- bestChromosome answer+ + return (before, after)++main = do+ -- Run the GA with the config "myconfig"+ let (before, after) = evalState getBest myconfig+ + -- Tell how many examples are correct within +/0 0.3+ putStrLn $ show $ round $ ANN.correctExamples xorExamples 0.3 before+ putStrLn $ show $ round $ ANN.correctExamples xorExamples 0.3 after+ + -- Print out the final neural network+ putStrLn $ show $ after
+ _darcs/pristine/examples/BitTest.hs view
@@ -0,0 +1,64 @@+import GA+import qualified Population.List as L+import Random+import Control.Monad.State+import List+import qualified Chromosome.Bits as B+import Control.Monad++myconfig = defaultConfig {+ -- cConfig configures the chromosome model and the genetic operators+ cConfig = B.config {+ -- This (trivial) fitness function just converts the bits to a double+ -- Larger numbers are "more fit"; the maximally fit chromosome is all 1's (True's)+ fitness = fromIntegral . B.bits2int,+ mutate = B.mutateBits (0.1 :: Double)+ -- The crossover operator defaults to point cross+ -- This only works for some chromosomes, such as bits+ },++ -- The population will be represented as a list+ pConfig = L.config,++ -- To generate the next population, mynewPopulation will be called+ newPopulation = mynewPopulation,+ + -- Stop after 100 generations+ maxGeneration = Just 100,+ + -- Initialize the random number generator to 42+ -- 42 is chosen for obvious reasons+ gen = mkStdGen 42+ }++-- This function takes a population ("pop"), then mutates it, then applies roulette selection+mynewPopulation pop = mutateM pop >>= rouletteM++-- Create an initial population of 100 bit lists+-- Each will have the 4 LSB randomly generated and the 4 MSB set to False+initPop = liftM (map (++[False,False,False,False])) $ replicateM 100 (B.randomBits 4)++getBest = do+ pop <- initPop+ + -- Grab the best chromosome at the start for comparision+ before <- bestChromosome pop+ + -- Evaluation of the GA+ answer <- run pop+ + -- Find the new best chromosome after running the GA+ after <- bestChromosome answer+ + return (before, after)++main = do+ -- Run the GA with the config "myconfig"+ let (before, after) = evalState getBest myconfig+ + -- Show the starting and ending fitness+ putStrLn $ show $ round $ fromIntegral $ B.bits2int before+ putStrLn $ show $ round $ fromIntegral $ B.bits2int after++ -- Print out the final chromosome+ putStrLn $ show after
+ _darcs/pristine/examples/GPTest.hs view
@@ -0,0 +1,75 @@+import GA+import qualified Population.List as L+import Random+import Control.Monad.State+import List+import qualified Chromosome.GP as GP+import Control.Monad++-- Defines the operators available for the GP+-- You must specify the function, then the arity (number of arguments), then the textual representation+ops :: [GP.Op Double Double]+ops = [+ GP.Op (\[x,y] -> return $ x + y) 2 "+", -- Addition+ GP.Op (\[x,y] -> return $ x - y) 2 "-", -- Subtraction+ GP.Op (\[x,y] -> return $ x * y) 2 "*", -- Multiplication+ GP.Op (\[] -> return 1) 0 "1", -- The constant 1+ GP.Op (\[] -> get) 0 "x" -- The independant variable+ ]++-- Examples for the function f(x) = 3x^2 + 1+examples :: [(Double,Double)]+examples = zip [1..10] $ map (\x -> 3 * x * x + 1) [1..10]++myconfig = defaultConfig {+ -- cConfig configures the chromosome model and the genetic operators+ cConfig = ChromosomeConfig {+ -- Compute fitness based on the mean square error across the examples+ fitness = GP.mseFitness examples,+ -- Max tree depth of 4, mutation rate of 0.05+ mutate = GP.mutate 4 ops (0.05 :: Double),+ -- Oops! crossover not yet implemented for GP, see GP.hs for details+ cross = error "Attempt to cross GP"+ },+ + -- The population will be represented as a list+ pConfig = L.config,++ -- To generate the next population, mynewPopulation will be called+ newPopulation = mynewPopulation,+ + -- Stop after 100 generations+ maxGeneration = Just 500,+ + -- Initialize the random number generator to 42+ -- 42 is chosen for obvious reasons+ gen = mkStdGen 42+ }+-- This function takes a population ("pop"), then mutates it, then applies roulette selection+mynewPopulation pop = mutateM pop >>= rouletteM++-- Create an initial population of 100 GP's +-- Tree depth of 4 using ops as the pool of available tree nodes+initPop = replicateM 100 $ GP.random 4 ops++getBest = do+ pop <- initPop+ + -- Grab the best chromosome at the start for comparision+ before <- bestChromosome pop+ + -- Evaluation of the GA+ answer <- run pop+ + -- Find the new best chromosome after running the GA+ after <- bestChromosome answer+ + return (before, after)++main = do+ -- Run the GA with the config "myconfig"+ let (before,after) = evalState getBest myconfig+ + -- Show the before/after s-expressions+ putStrLn $ show $ before+ putStrLn $ show $ after
+ _darcs/tentative_pristine view
@@ -0,0 +1,16 @@+hunk ./examples/GPTest.hs 15++ GP.Op (\[x,y] -> return $ x * y) 2 "*", -- Multiplication+hunk ./examples/GPTest.hs 20+--- Examples for the function f(x) = 2x + 1++-- Examples for the function f(x) = 3x^2 + 1+hunk ./examples/GPTest.hs 22+-examples = zip [1..10] $ map (\x -> 2 * x + 1) [1..10]++examples = zip [1..10] $ map (\x -> 3 * x * x + 1) [1..10]+hunk ./examples/GPTest.hs 42+- maxGeneration = Just 100,++ maxGeneration = Just 500,+hunk ./examples/GPTest.hs 52+--- Tree depth of 3 using ops as the pool of available tree nodes+-initPop = replicateM 100 $ GP.random 3 ops++-- Tree depth of 4 using ops as the pool of available tree nodes++initPop = replicateM 100 $ GP.random 4 ops
+ examples/ANNTest.hs view
@@ -0,0 +1,70 @@+import GA+import qualified Population.List as L+import Random+import Control.Monad.State+import List+import qualified Chromosome.ANN as ANN+import Control.Monad+++-- This function takes a population ("pop"), then mutates it, then applies roulette selection+mynewPopulation pop = mutateM pop >>= rouletteM+++myconfig = defaultConfig {+ -- cConfig configures the chromosome model and the genetic operators+ cConfig = ANN.config {+ fitness = ANN.fitnessMSE xorExamples,+ mutate = ANN.mutateShift 0.1 1.0,+ cross = ANN.uniformCross+ },++ -- The population will be represented as a list+ pConfig = L.config,++ -- To generate the next population, mynewPopulation will be called+ newPopulation = mynewPopulation,++ -- Stop after 1000 generations+ maxGeneration = Just 1000,++ -- Initialize the random number generator to 42+ -- 42 is chosen for obvious reasons+ gen = mkStdGen 42+ }++-- Create an initial population of 20 ANN's+-- Each will have 2 inputs and two hidden layers of [2,1] nodes, respectively+-- The weights will be randomly initialized to +/- 2.0+initPop = replicateM 20 $ ANN.randomANN 2 [2,1] 2.0++-- The examples are a list of (in, out)+xorExamples =+ zip xorIn xorOut+ where xorIn = [[0.0,0.0], [1.0,1.0], [1.0,0.0], [0.0,1.0]]+ xorOut = [[0.0], [0.0], [1.0], [1.0]]++getBest = do+ pop <- initPop+ + -- Grab the best chromosome at the start for comparision+ before <- bestChromosome pop+ + -- Evaluation of the GA+ answer <- run pop+ + -- Find the new best chromosome after running the GA+ after <- bestChromosome answer+ + return (before, after)++main = do+ -- Run the GA with the config "myconfig"+ let (before, after) = evalState getBest myconfig+ + -- Tell how many examples are correct within +/0 0.3+ putStrLn $ show $ round $ ANN.correctExamples xorExamples 0.3 before+ putStrLn $ show $ round $ ANN.correctExamples xorExamples 0.3 after+ + -- Print out the final neural network+ putStrLn $ show $ after
+ examples/BitTest.hs view
@@ -0,0 +1,64 @@+import GA+import qualified Population.List as L+import Random+import Control.Monad.State+import List+import qualified Chromosome.Bits as B+import Control.Monad++myconfig = defaultConfig {+ -- cConfig configures the chromosome model and the genetic operators+ cConfig = B.config {+ -- This (trivial) fitness function just converts the bits to a double+ -- Larger numbers are "more fit"; the maximally fit chromosome is all 1's (True's)+ fitness = fromIntegral . B.bits2int,+ mutate = B.mutateBits (0.1 :: Double)+ -- The crossover operator defaults to point cross+ -- This only works for some chromosomes, such as bits+ },++ -- The population will be represented as a list+ pConfig = L.config,++ -- To generate the next population, mynewPopulation will be called+ newPopulation = mynewPopulation,+ + -- Stop after 100 generations+ maxGeneration = Just 100,+ + -- Initialize the random number generator to 42+ -- 42 is chosen for obvious reasons+ gen = mkStdGen 42+ }++-- This function takes a population ("pop"), then mutates it, then applies roulette selection+mynewPopulation pop = mutateM pop >>= rouletteM++-- Create an initial population of 100 bit lists+-- Each will have the 4 LSB randomly generated and the 4 MSB set to False+initPop = liftM (map (++[False,False,False,False])) $ replicateM 100 (B.randomBits 4)++getBest = do+ pop <- initPop+ + -- Grab the best chromosome at the start for comparision+ before <- bestChromosome pop+ + -- Evaluation of the GA+ answer <- run pop+ + -- Find the new best chromosome after running the GA+ after <- bestChromosome answer+ + return (before, after)++main = do+ -- Run the GA with the config "myconfig"+ let (before, after) = evalState getBest myconfig+ + -- Show the starting and ending fitness+ putStrLn $ show $ round $ fromIntegral $ B.bits2int before+ putStrLn $ show $ round $ fromIntegral $ B.bits2int after++ -- Print out the final chromosome+ putStrLn $ show after
+ examples/GPTest.hs view
@@ -0,0 +1,75 @@+import GA+import qualified Population.List as L+import Random+import Control.Monad.State+import List+import qualified Chromosome.GP as GP+import Control.Monad++-- Defines the operators available for the GP+-- You must specify the function, then the arity (number of arguments), then the textual representation+ops :: [GP.Op Double Double]+ops = [+ GP.Op (\[x,y] -> return $ x + y) 2 "+", -- Addition+ GP.Op (\[x,y] -> return $ x - y) 2 "-", -- Subtraction+ GP.Op (\[x,y] -> return $ x * y) 2 "*", -- Multiplication+ GP.Op (\[] -> return 1) 0 "1", -- The constant 1+ GP.Op (\[] -> get) 0 "x" -- The independant variable+ ]++-- Examples for the function f(x) = 3x^2 + 1+examples :: [(Double,Double)]+examples = zip [1..10] $ map (\x -> 3 * x * x + 1) [1..10]++myconfig = defaultConfig {+ -- cConfig configures the chromosome model and the genetic operators+ cConfig = ChromosomeConfig {+ -- Compute fitness based on the mean square error across the examples+ fitness = GP.mseFitness examples,+ -- Max tree depth of 4, mutation rate of 0.05+ mutate = GP.mutate 4 ops (0.05 :: Double),+ -- Oops! crossover not yet implemented for GP, see GP.hs for details+ cross = error "Attempt to cross GP"+ },+ + -- The population will be represented as a list+ pConfig = L.config,++ -- To generate the next population, mynewPopulation will be called+ newPopulation = mynewPopulation,+ + -- Stop after 100 generations+ maxGeneration = Just 500,+ + -- Initialize the random number generator to 42+ -- 42 is chosen for obvious reasons+ gen = mkStdGen 42+ }+-- This function takes a population ("pop"), then mutates it, then applies roulette selection+mynewPopulation pop = mutateM pop >>= rouletteM++-- Create an initial population of 100 GP's +-- Tree depth of 4 using ops as the pool of available tree nodes+initPop = replicateM 100 $ GP.random 4 ops++getBest = do+ pop <- initPop+ + -- Grab the best chromosome at the start for comparision+ before <- bestChromosome pop+ + -- Evaluation of the GA+ answer <- run pop+ + -- Find the new best chromosome after running the GA+ after <- bestChromosome answer+ + return (before, after)++main = do+ -- Run the GA with the config "myconfig"+ let (before,after) = evalState getBest myconfig+ + -- Show the before/after s-expressions+ putStrLn $ show $ before+ putStrLn $ show $ after
+ hgalib.cabal view
@@ -0,0 +1,20 @@+name: hgalib+version: 0.1+synopsis: Haskell Genetic Algorithm Library+description: Haskell Genetic Algorithm Library+category: AI+license: PublicDomain+license-file: LICENSE+author: Kevin Ellis+maintainer: Kevin Ellis <ellisk@catlin.edu>+build-type: Simple+Cabal-Version: >= 1.2+Library+ exposed-modules: GA,+ Population.List,+ Population.Array,+ Chromosome.Bits,+ Chromosome.ANN,+ Chromosome.GP+ ghc-options: -O2+ build-depends: base >= 3, array, mtl, haskell98