HSGEP 0.1.0 → 0.1.1
raw patch · 18 files changed
+476/−531 lines, 18 filesdep +csvdep +monad-mersenne-randomdep +vectordep −parsecdep −randomnew-component:exe:HSGEP_CADensity
Dependencies added: csv, monad-mersenne-random, vector
Dependencies removed: parsec, random
Files
- Examples/Regression/test3.in +2/−2
- Examples/Regression/test6.csv +101/−0
- Examples/Regression/test6.in +27/−0
- GEP/Examples/CADensity/Driver.hs +72/−0
- GEP/Examples/Regression/ArithmeticIndividual.hs +0/−218
- GEP/Examples/Regression/Driver.hs +12/−18
- GEP/Examples/Regression/FitnessInput.hs +0/−68
- GEP/Fitness.hs +26/−11
- GEP/GeneOperations.hs +45/−34
- GEP/GenericDriver.hs +3/−17
- GEP/MonadicGeneOperations.hs +12/−12
- GEP/Random.hs +28/−25
- GEP/Rmonad.hs +16/−27
- GEP/Selection.hs +2/−2
- GEP/TimeStep.hs +97/−86
- GEP/Types.hs +11/−6
- HSGEP.cabal +14/−4
- README +8/−1
Examples/Regression/test3.in view
@@ -16,12 +16,12 @@ maxISLen = 4 maxRISLen = 4 -populationSize = 30+populationSize = 180 rouletteExponent = 1.25 maxFitness = 20000.0 -numGenerations = 100+numGenerations = 200 selectionRange = 1000.0
+ Examples/Regression/test6.csv view
@@ -0,0 +1,101 @@+x,y,z+-1.0,-1.0,0.826821810431806+-1.0,-0.7777777777777778,0.9577669878835238+-1.0,-0.5555555555555556,0.9997677368763108+-1.0,-0.3333333333333333,0.9446632841065206+-1.0,-0.1111111111111111,0.8031604611869176+-1.0,0.1111111111111111,0.6027533601840789+-1.0,0.3333333333333333,0.38238121334850533+-1.0,0.5555555555555556,0.18486247453852742+-1.0,0.7777777777777778,0.04857516532055068+-1.0,1.0,0.0+-0.7777777777777778,-1.0,0.9577669878835238+-0.7777777777777778,-0.7777777777777778,0.9997677368763108+-0.7777777777777778,-0.5555555555555556,0.9446632841065206+-0.7777777777777778,-0.3333333333333333,0.8031604611869176+-0.7777777777777778,-0.1111111111111111,0.6027533601840789+-0.7777777777777778,0.1111111111111111,0.38238121334850533+-0.7777777777777778,0.3333333333333333,0.18486247453852742+-0.7777777777777778,0.5555555555555556,0.04857516532055068+-0.7777777777777778,0.7777777777777778,0.0+-0.7777777777777778,1.0,0.04857516532055068+-0.5555555555555556,-1.0,0.9997677368763108+-0.5555555555555556,-0.7777777777777778,0.9446632841065206+-0.5555555555555556,-0.5555555555555556,0.8031604611869176+-0.5555555555555556,-0.3333333333333333,0.6027533601840789+-0.5555555555555556,-0.1111111111111111,0.38238121334850533+-0.5555555555555556,0.1111111111111111,0.18486247453852742+-0.5555555555555556,0.3333333333333333,0.04857516532055068+-0.5555555555555556,0.5555555555555556,0.0+-0.5555555555555556,0.7777777777777778,0.04857516532055068+-0.5555555555555556,1.0,0.18486247453852742+-0.3333333333333333,-1.0,0.9446632841065206+-0.3333333333333333,-0.7777777777777778,0.8031604611869176+-0.3333333333333333,-0.5555555555555556,0.6027533601840789+-0.3333333333333333,-0.3333333333333333,0.38238121334850533+-0.3333333333333333,-0.1111111111111111,0.18486247453852742+-0.3333333333333333,0.1111111111111111,0.04857516532055068+-0.3333333333333333,0.3333333333333333,0.0+-0.3333333333333333,0.5555555555555556,0.04857516532055068+-0.3333333333333333,0.7777777777777778,0.18486247453852742+-0.3333333333333333,1.0,0.38238121334850533+-0.1111111111111111,-1.0,0.8031604611869176+-0.1111111111111111,-0.7777777777777778,0.6027533601840789+-0.1111111111111111,-0.5555555555555556,0.38238121334850533+-0.1111111111111111,-0.3333333333333333,0.18486247453852742+-0.1111111111111111,-0.1111111111111111,0.04857516532055068+-0.1111111111111111,0.1111111111111111,0.0+-0.1111111111111111,0.3333333333333333,0.04857516532055068+-0.1111111111111111,0.5555555555555556,0.18486247453852742+-0.1111111111111111,0.7777777777777778,0.38238121334850533+-0.1111111111111111,1.0,0.6027533601840789+0.1111111111111111,-1.0,0.6027533601840789+0.1111111111111111,-0.7777777777777778,0.38238121334850533+0.1111111111111111,-0.5555555555555556,0.18486247453852742+0.1111111111111111,-0.3333333333333333,0.04857516532055068+0.1111111111111111,-0.1111111111111111,0.0+0.1111111111111111,0.1111111111111111,0.04857516532055068+0.1111111111111111,0.3333333333333333,0.18486247453852742+0.1111111111111111,0.5555555555555556,0.38238121334850533+0.1111111111111111,0.7777777777777778,0.6027533601840789+0.1111111111111111,1.0,0.8031604611869176+0.3333333333333333,-1.0,0.38238121334850533+0.3333333333333333,-0.7777777777777778,0.18486247453852742+0.3333333333333333,-0.5555555555555556,0.04857516532055068+0.3333333333333333,-0.3333333333333333,0.0+0.3333333333333333,-0.1111111111111111,0.04857516532055068+0.3333333333333333,0.1111111111111111,0.18486247453852742+0.3333333333333333,0.3333333333333333,0.38238121334850533+0.3333333333333333,0.5555555555555556,0.6027533601840789+0.3333333333333333,0.7777777777777778,0.8031604611869176+0.3333333333333333,1.0,0.9446632841065206+0.5555555555555556,-1.0,0.18486247453852742+0.5555555555555556,-0.7777777777777778,0.04857516532055068+0.5555555555555556,-0.5555555555555556,0.0+0.5555555555555556,-0.3333333333333333,0.04857516532055068+0.5555555555555556,-0.1111111111111111,0.18486247453852742+0.5555555555555556,0.1111111111111111,0.38238121334850533+0.5555555555555556,0.3333333333333333,0.6027533601840789+0.5555555555555556,0.5555555555555556,0.8031604611869176+0.5555555555555556,0.7777777777777778,0.9446632841065206+0.5555555555555556,1.0,0.9997677368763108+0.7777777777777778,-1.0,0.04857516532055068+0.7777777777777778,-0.7777777777777778,0.0+0.7777777777777778,-0.5555555555555556,0.04857516532055068+0.7777777777777778,-0.3333333333333333,0.18486247453852742+0.7777777777777778,-0.1111111111111111,0.38238121334850533+0.7777777777777778,0.1111111111111111,0.6027533601840789+0.7777777777777778,0.3333333333333333,0.8031604611869176+0.7777777777777778,0.5555555555555556,0.9446632841065206+0.7777777777777778,0.7777777777777778,0.9997677368763108+0.7777777777777778,1.0,0.9577669878835238+1.0,-1.0,0.0+1.0,-0.7777777777777778,0.04857516532055068+1.0,-0.5555555555555556,0.18486247453852742+1.0,-0.3333333333333333,0.38238121334850533+1.0,-0.1111111111111111,0.6027533601840789+1.0,0.1111111111111111,0.8031604611869176+1.0,0.3333333333333333,0.9446632841065206+1.0,0.5555555555555556,0.9997677368763108+1.0,0.7777777777777778,0.9577669878835238+1.0,1.0,0.826821810431806
+ Examples/Regression/test6.in view
@@ -0,0 +1,27 @@+rateMutate = 0.1+rate1R = 0.3+rate2R = 0.3+rateGR = 0.075+rateIS = 0.3+rateRIS = 0.2+rateGT = 0.25++genomeTerminals = xy+genomeNonterminals = +-/*+genomeMaxArity = 2+genomeNumGenes = 6+genomeHeadLength = 20+genomeGeneConnector = +++maxISLen = 3+maxRISLen = 4++populationSize = 100++rouletteExponent = 1.10++maxFitness = 100000++numGenerations = 35++selectionRange = 1000.0
+ GEP/Examples/CADensity/Driver.hs view
@@ -0,0 +1,72 @@+-- |+-- Haskell gene expression programming, density classification example+-- +-- Author: mjsottile\@computer.org+--+module Main (+ main+) where++import GEP.Params+import GEP.GenericDriver+import GEP.Util.ConfigurationReader+import GEP.Examples.CADensity.CADensityIndividual+import GEP.Examples.CADensity.CAFitness+import System.Environment (getArgs)+import System.Exit++--+-- sanity check arguments to see if we have enough+--+validateArgs :: [String] -> IO ()+validateArgs s = do + if (length s < 2) then do putStrLn "Must specify config file and fitness test data file names."+ exitFailure+ else do return ()++--+main :: IO ()+main = do+ -- read in parameters from specified file+ args <- getArgs++ -- sanity check+ validateArgs args++ -- give args nice names+ configFile <- return $ head args+ fitnessFile <- return $ head (tail args)++ -- if optional third argument is present, assume it is dot file+ dotfile <- if ((length args) == 3) then return $ Just $head (tail (tail args))+ else return $ Nothing+ + -- read parameters+ (rs,gnome,params) <- readParameters configFile+ + -- read fitness test data+ (testDict, ys) <- readFitnessInput fitnessFile++ -- call generic driver+ (best,pop) <- gepDriver params rs gnome testDict ys fitness_evaluate_absolute express_individual++ -- Express best individual+ bestExpressed <- return $ express_individual (head pop) gnome+ + -- Flatten best individual via infix walk+ bestString <- return $ infixWalker bestExpressed++ -- report status+ putStrLn "-------------------------------------------------"+ putStrLn $ "DONE : "++(show best)+ putStrLn $ "INFIX : "++bestString ++ putStrLn $ "MAXIMA OUTPUT :"+ -- send flattened individual to maxima for pretty printing+ maxOut <- maximaExpand bestString "qubu.net" 12777++ -- print lines that come back+ mapM putStrLn maxOut++ -- dump to dot file if one was specified+ dumpDotFile dotfile bestExpressed
− GEP/Examples/Regression/ArithmeticIndividual.hs
@@ -1,218 +0,0 @@-{-|- Code for individuals representing arithmetic expressions. This is used- most frequently for regression applications.-- Author: mjsottile\@computer.org--}-module GEP.Examples.Regression.ArithmeticIndividual(- express_individual,- evaluate,- fitness_evaluate_absolute,- fitness_evaluate_relative,- evaluate_nodes,- infixWalker,- aiToGraphviz,- dumpDotFile-) where--import GEP.Types-import Maybe-import IO--data BinOperator = Plus | Minus | Divide | Times | Exp- deriving Show--data UnOperator = Sqrt- deriving Show--data AINode = BinOp BinOperator AINode AINode- | UnOp UnOperator AINode- | GeneConnector AINode- | Terminal Char- deriving Show------- dump an expressed individual to a file as a graphviz dot file----dumpDotFile :: Maybe String -> AINode -> IO ()-dumpDotFile Nothing _ = return ()-dumpDotFile (Just fname) n = do- fh <- openFile fname WriteMode- hPutStrLn fh "digraph HSGEP_Regression {"- mapM (hPutStrLn fh) (aiToGraphviz n)- hPutStrLn fh "}"- hClose fh---- Node, parent ID, (kidsstring,maxkidid)-arithToGraphviz :: AINode -> Int -> Bool -> ([String],Int)-arithToGraphviz (Terminal c) i _ =- ([" "++ident++" [label=\""++lbl++"\"];"], i')- where- i' = i+1- ident = "l"++(show i')- lbl = (show c)--arithToGraphviz (UnOp Sqrt kidNodes) i isGC =- ([" "++ident++" [label=\""++lbl++"\""++special++"];",- " "++ident++" -> "++kidIdent++";"]++kids, kidID)- where- special = if isGC then ", color=red" else ""- i' = i+1- (kids,kidID) = arithToGraphviz kidNodes i' False- ident = "l"++(show i')- kidIdent = "l"++(show (i'+1))- lbl = "Q"--arithToGraphviz (BinOp bop lKids rKids) i isGC =- ([" "++ident++" [label=\""++ops++"\""++special++"];",- " "++ident++" -> "++lkidIdent++";",- " "++ident++" -> "++rkidIdent++";"]++lkidlist++rkidlist, rkidID)- where- special = if isGC then ", color=red" else ""- i' = i+1- ident = "l"++(show i')- lkidIdent = "l"++(show (i'+1))- (lkidlist,lkidID) = arithToGraphviz lKids i' False- rkidIdent = "l"++(show (lkidID+1))- (rkidlist,rkidID) = arithToGraphviz rKids lkidID False- ops = case bop of- Minus -> "-"- Plus -> "+"- Divide -> "/"- Times -> "*"- Exp -> "^"--arithToGraphviz (GeneConnector g) i _ = arithToGraphviz g i True--aiToGraphviz :: AINode -> [String]-aiToGraphviz n = ss- where- (ss,_) = arithToGraphviz n 0 False--type AISymTable = SymTable Double--{-|- Return the arity of a character representing a terminal or nonterminal.-- TODO: This should be made part of the genome, and the arity of each- symbol should be specified with the symbols in the input file.--}-arity :: Char -> Int-arity 'Q' = 1-arity '-' = 2-arity '+' = 2-arity '*' = 2-arity '/' = 2-arity '^' = 2-arity _ = 0--levelize :: [Char] -> Int -> [[Char]]-levelize _ 0 = []-levelize [] _ = []-levelize s i =- [front]++(levelize back (foldr (+) 0 (map arity front)))- where- (front,back) = splitAt i s--infixWalker :: AINode -> String-infixWalker (Terminal c) = [c]-infixWalker (UnOp Sqrt e) = "sqrt("++(infixWalker e)++")"-infixWalker (GeneConnector g) = infixWalker g-infixWalker (BinOp op a b) = "("++as++ops++bs++")"- where- as = infixWalker a- bs = infixWalker b- ops = case op of- Minus -> "-"- Plus -> "+"- Divide -> "/"- Times -> "*"- Exp -> "^"--express :: Char -> [AINode] -> AINode-express c kids =- case c of- 'Q' -> UnOp Sqrt lhs- '-' -> BinOp Minus lhs rhs- '+' -> BinOp Plus lhs rhs- '*' -> BinOp Times lhs rhs- '/' -> BinOp Divide lhs rhs- '^' -> BinOp Exp lhs rhs- _ -> Terminal c- where- lhs = head kids- rhs = head (tail kids)--lvlAssemble :: [Char] -> [AINode] -> [AINode]-lvlAssemble [] _ = []-lvlAssemble (c:cs) kids = - [express c cneed]++(lvlAssemble cs csneed)- where- ac = arity c- (cneed,csneed) = splitAt ac kids--assemble :: [[Char]] -> [AINode]-assemble [] = []-assemble (c:[]) = (map (\x -> Terminal x) c)-assemble (c:cs) = lvlAssemble c (assemble cs)--express_individual :: Individual -> Genome -> AINode-express_individual chrom g = - connect_genes g ets- where- genes = chromToGenes chrom (geneLength g)- ets = map (\i -> head (assemble (levelize i 1))) genes--connect_genes :: Genome -> [AINode] -> AINode-connect_genes g x | length x == 1 = head x-connect_genes g x | otherwise = connect_genes g (xh':ys)- where- c = geneConnector g- xh = head x- xs = tail x- y = head xs- ys = tail xs- xh' = GeneConnector (express c [xh,y])--lookup_sym :: Char -> AISymTable -> Maybe Double-lookup_sym _ [] = Nothing-lookup_sym '1' _ = Just 1.0-lookup_sym sym ((c,x):syms) =- if sym==c - then - Just x - else - (lookup_sym sym syms)--evaluate :: AINode -> AISymTable -> Double-evaluate node syms =- case node of- (GeneConnector g) -> evaluate g syms- (BinOp op a b) ->- let ea = evaluate a syms in- let eb = evaluate b syms- in- case op of- Plus -> ea + eb- Minus -> ea - eb- Times -> ea * eb- Divide -> ea / eb- Exp -> ea ** eb- (UnOp Sqrt a) -> sqrt(evaluate a syms)- (Terminal x) -> fromJust (lookup_sym x syms)--evaluate_nodes :: [AINode] -> AISymTable -> [Double]-evaluate_nodes nodes syms =- map (\x -> evaluate x syms) nodes--fitness_evaluate_absolute :: AINode -> AISymTable -> Double -> Double -> Double-fitness_evaluate_absolute node syms target selection_range =- selection_range - (abs (c - target))- where- c = evaluate node syms--fitness_evaluate_relative :: AINode -> AISymTable -> Double -> Double -> Double-fitness_evaluate_relative node syms target selection_range =- selection_range - (abs ( ( (c - target) / target ) * 100.0 ) )- where- c = evaluate node syms
GEP/Examples/Regression/Driver.hs view
@@ -7,28 +7,24 @@ main ) where -import GEP.Params import GEP.GenericDriver import GEP.Util.ConfigurationReader import GEP.Examples.Regression.ArithmeticIndividual import GEP.Examples.Regression.FitnessInput import GEP.Examples.Regression.MaximaClient import System.Environment (getArgs)-import System.Exit+import Control.Monad (when) -- -- sanity check arguments to see if we have enough -- validateArgs :: [String] -> IO ()-validateArgs s = do - if (length s < 2) then do putStrLn "Must specify config file and fitness test data file names."- exitFailure- else do return ()+validateArgs s =+ when (length s < 2) $+ error "Must specify config file and fitness test data file names." ----- currently this is here to shut up whining tools who just really --- need a main nearby to make them feel good. that means you haddock.--- you're not even a linker - get over the lack of main already...+-- main -- main :: IO () main = do@@ -39,11 +35,11 @@ validateArgs args -- give args nice names- configFile <- return $ head args- fitnessFile <- return $ head (tail args)+ let configFile = head args+ let fitnessFile = head (tail args) -- if optional third argument is present, assume it is dot file- dotfile <- if ((length args) == 3) then return $ Just $head (tail (tail args))+ dotfile <- if length args == 3 then return $ Just $head (tail (tail args)) else return $ Nothing -- read parameters@@ -56,10 +52,10 @@ (best,pop) <- gepDriver params rs gnome testDict ys fitness_evaluate_absolute express_individual -- Express best individual- bestExpressed <- return $ express_individual (head pop) gnome+ let bestExpressed = express_individual (head pop) gnome -- Flatten best individual via infix walk- bestString <- return $ infixWalker bestExpressed+ let bestString = infixWalker bestExpressed -- report status putStrLn "-------------------------------------------------"@@ -68,10 +64,8 @@ putStrLn $ "MAXIMA OUTPUT :" -- send flattened individual to maxima for pretty printing- maxOut <- maximaExpand bestString "qubu.net" 12777-- -- print lines that come back- mapM putStrLn maxOut+ -- and print lines that come back+ maximaExpand bestString "qubu.net" 12777 >>= mapM_ putStrLn -- dump to dot file if one was specified dumpDotFile dotfile bestExpressed
− GEP/Examples/Regression/FitnessInput.hs
@@ -1,68 +0,0 @@-{-|-- Code to read input data files containing the test inputs and test outputs- used to evaluate the fitness of individuals.-- Author: mjsottile\@computer.org-- NOTE: Parsec code for CSV files ---}-module GEP.Examples.Regression.FitnessInput (- readFitnessInput-) where--import Text.ParserCombinators.Parsec-import System.Exit------- assume files have CSV format with a header row where each entry in the--- header row names a variable. note that currently we require these to--- be single characters. eventually we may automate the process of mapping--- variables onto characters in the genome to allow more expressive names--- to be associated with variables.------- PARSEC STUFF--csvfile = many csvline--csvline = do- entries <- (sepBy entry (char ','))- newline- return entries---- entry accepts any string containing alphanum or periods, with spaces either--- before or after the value.-entry = do- many (char ' ')- body <- many (noneOf ",\n")- many (char ' ')- return body---- END PARSEC STUFF--type FitnessDict = [[(Char,Double)]]--dictify :: [String] -> [[String]] -> (FitnessDict, [Double])-dictify lbls values =- (map (\j -> zip (init charLbls) j) (init floatValues),- map last floatValues)- where- charLbls = map head lbls- floatValues = map (\j -> map (\i -> (read i) :: Double) j) values---- function that takes a filename and returns a dictionary-readFitnessInput :: String -> IO (FitnessDict,[Double])-readFitnessInput fname = do- result <- parseFromFile csvfile fname- case result of Left err -> do putStrLn "Bad regression fitness input!"- exitFailure- Right xs -> do return $ dictify (head xs) (tail xs)--{--main :: IO ()-main = do- x <- readFitnessInput "test.csv"- print x--}
GEP/Fitness.hs view
@@ -9,14 +9,29 @@ -- -- mjsottile\@computer.org ---module GEP.Fitness (- fitness_tester,- fitness_filter,- sortByFitness-) where+module GEP.Fitness+ ( FitnessFunction+ , TestCase+ , TestDict+ , TestOuts+ , fitness_tester+ , fitness_filter+ , sortByFitness+ ) where import GEP.Types+-- | Fitness function type+type FitnessFunction a b = a -> TestCase b -> Double -> Double -> Double +-- | A test case maps a list of terminals to float values+type TestCase a = SymTable a++-- | A test dictionary is a set of test cases+type TestDict a = [TestCase a]++-- | The set of outputs expected for each entry in the test dictionary+type TestOuts = [Double]+ -- -- Sort a list of pairs by first element of each pair. Disregard duplicates -- pairs.@@ -34,9 +49,9 @@ -- and use a more general approach like evaluateFitness above. -- fitness_tester :: a -- ^ Expressed individual- -> (a -> b -> Double -> Double -> Double) -- ^ Fitness function- -> [b] -- ^ List of symbol tables for test cases- -> [Double] -- ^ List of expected outputs for test cases+ -> FitnessFunction a b -- ^ Fitness function+ -> TestDict b -- ^ List of symbol tables for test cases+ -> TestOuts -- ^ List of expected outputs for test cases -> Double -- ^ Range of selection. M in original -- GEP paper equations for fitness. -> Double -- ^ Fitness value for given individual@@ -53,8 +68,8 @@ -- that are +/- infinity or NaN are removed. -- fitness_filter :: [Double] -- ^ Fitness values- -> [Individual] -- ^ Individuals- -> [(Double,Individual)] -- ^ Paired fitness/individuals after + -> [Chromosome] -- ^ Individuals+ -> [(Double, Chromosome)] -- ^ Paired fitness/individuals after -- filtering fitness_filter fitnesses pop = foldr (\(i,j) -> @@ -66,5 +81,5 @@ -- | -- Sort a set of individuals with fitness values by their fitness ---sortByFitness :: [(Double,Individual)] -> [(Double,Individual)]+sortByFitness :: [(Double, Chromosome)] -> [(Double, Chromosome)] sortByFitness xs = reverse (pairSort xs)
GEP/GeneOperations.hs view
@@ -22,11 +22,32 @@ import GEP.Types +-- There is a set of basic (not GA) operations on Sequences, Genes and+-- Chromosomes, mainly composition and splitting.+-- These should be encapsulated to allow flexible transition from one type of+-- sequences---e.g. [Char]---to any other---e.g. ByteString---wo affecting the+-- GA operators.+++-- | Splits a sequence into three by given positions. Similar to the splitAt but+-- for two positions. The positions must be in a non-descending order. This is+-- not checked.+splitThirds :: (Int, Int) -> Sequence -> (Sequence, Sequence, Sequence)+splitThirds (l1, l2) x = (fx,mx,bx)+ where+ (fx,tmp) = splitAt l1 x+ (mx,bx) = splitAt (l2-l1) tmp+++-- The rest of the code covers the GA operators.+--++ -- | -- One-point crossover-crossover1pt :: ([Symbol], [Symbol]) -- ^ Pair of individuals before crossover+crossover1pt :: (Chromosome, Chromosome) -- ^ Pair of individuals before crossover -> Int -- ^ Crossover point- -> ([Symbol],[Symbol]) -- ^ Pair of individuals after crossover+ -> (Chromosome, Chromosome) -- ^ Pair of individuals after crossover crossover1pt (x,y) loc = (x', y') where (fx, bx) = splitAt (loc-1) x@@ -34,28 +55,19 @@ x' = fx++by y' = fy++bx ------ helper to split a list into three parts. ----splitThirds :: [a] -> Int -> Int -> ([a],[a],[a])-splitThirds x l1 l2 = (fx,mx,bx)- where- (fx,tmp) = splitAt l1 x- (mx,bx) = splitAt (l2-l1) tmp- -- | -- Two-point crossover-crossover2pt :: ([Symbol], [Symbol]) -- ^ Pair of individuals before crossover+crossover2pt :: (Chromosome, Chromosome) -- ^ Pair of individuals before crossover -> Int -- ^ Crossover point 1 -> Int -- ^ Crossover point 2- -> ([Symbol],[Symbol]) -- ^ Pair of individuals after crossover+ -> (Chromosome, Chromosome) -- ^ Pair of individuals after crossover crossover2pt (x,y) loc1 loc2 = (x',y') where -- make sure we know which location is lower than the other minLoc = min loc1 loc2 maxLoc = max loc1 loc2- (fx,mx,bx) = splitThirds x (minLoc-1) (maxLoc-1)- (fy,my,by) = splitThirds y (minLoc-1) (maxLoc-1)+ (fx,mx,bx) = splitThirds (minLoc-1, maxLoc-1) x+ (fy,my,by) = splitThirds (minLoc-1, maxLoc-1) y x' = fx++my++bx y' = fy++mx++by @@ -63,19 +75,19 @@ -- Helper to extract a gene from a sequence and return the sequence -- before the gene, the gene itself, and the sequence after the gene. ---geneExtract :: [Symbol] -> Int -> Int -> ([Symbol],[Symbol],[Symbol])+geneExtract :: Chromosome -> Int -> Int -> (Sequence, Gene, Sequence) geneExtract x gene geneLen = (before, theGene, after) where geneStart = geneLen * gene geneEnd = geneStart + geneLen- (before,theGene,after) = splitThirds x geneStart geneEnd+ (before,theGene,after) = splitThirds (geneStart, geneEnd) x -- | -- Gene crossover-crossoverGene :: ([Symbol], [Symbol]) -- ^ Pair of individuals before crossover+crossoverGene :: (Sequence, Sequence) -- ^ Pair of individuals before crossover -> Int -- ^ Gene number for crossover -> Int -- ^ Gene length in symbols- -> ([Symbol], [Symbol]) -- ^ Pair of individuals after crossover+ -> (Sequence, Sequence) -- ^ Pair of individuals after crossover crossoverGene (x,y) gene geneLen = (x',y') where (fx,mx,bx) = geneExtract x gene geneLen@@ -85,23 +97,22 @@ -- -- Find a root insertion sequence within a sequence. This means looking--- for the first subsequence that starts with a nonterminal. If no such--- subsequence exists, return the empty list.+-- for the first subsequence that starts with a nonterminal. If no such+-- subsequence exists, return an empty list. ---findRIS :: [Symbol] -> Genome -> [Symbol]-findRIS [] _ = []-findRIS (x:xs) g | (isNonterminal x g) = (x:xs)-findRIS (_:xs) g | otherwise = findRIS xs g+findRIS :: Genome -> Sequence -> Sequence+findRIS g = dropWhile isT+ where isT x = not $ isNonterminal x g -- | -- Root insertion sequence transposition.-transposeRIS :: [Symbol] -- ^ Sequence to perform RIS transposition on+transposeRIS :: Sequence -- ^ Sequence to perform RIS transposition on -> Genome -- ^ Genome information -> Int -- ^ Gene to perform RIS transposition within -> Int -- ^ Position within gene to start search for -- RIS for transposition -> Int -- ^ Length of RIS- -> [Symbol] -- ^ Sequence after RIS transposition performed+ -> Sequence -- ^ Sequence after RIS transposition performed transposeRIS x genome gene pos len = fx ++ risSeq ++ keepHead ++ geneTail ++ bx where@@ -115,7 +126,7 @@ -- find the root insertion sequence within the candidate region given -- by the search start position risCandidateRegion = drop pos theGene- risSeq = take len (findRIS risCandidateRegion genome)+ risSeq = take len (findRIS genome risCandidateRegion) -- determine how much of the head to preserve based on the length of -- the root insertion sequence@@ -125,7 +136,7 @@ -- are preserved after transposition keepHead = take keepHeadlen geneHead -insertIntoGene :: [Symbol] -> [Symbol] -> Int -> Int -> [Symbol]+insertIntoGene :: Gene -> Sequence -> Int -> Int -> Gene insertIntoGene x ins hl pos = (take hl (pre++ins++post))++tX where hX = take hl x@@ -135,13 +146,13 @@ -- | -- Insertion sequence transposition.-transposeIS :: [Symbol] -- ^ Chromosome+transposeIS :: Chromosome -- ^ Chromosome -> Genome -- ^ Genome -> Int -- ^ Gene number -> Int -- ^ Position to take from within a gene -> Int -- ^ Length to take -> Int -- ^ Position to put within a gene- -> [Symbol] -- ^ Resulting chromosome+ -> Chromosome -- ^ Resulting chromosome transposeIS x genome genenum takepos len putpos = genesBefore ++ gene' ++ genesAfter where@@ -152,11 +163,11 @@ -- | -- Gene transposition.-transposeGene :: [Symbol] -- ^ Chromosome+transposeGene :: Chromosome -- ^ Chromosome -> Genome -- ^ Genome -> Int -- ^ Gene number- -> [Symbol] -- ^ Resulting chromosome-transposeGene x genome gnum = gene++pregene++postgene+ -> Chromosome -- ^ Resulting chromosome+transposeGene x genome gnum = concat [gene, pregene, postgene] where geneLen = (headLength genome) + (tailLength genome) gene = take geneLen (drop (geneLen * gnum) x)
GEP/GenericDriver.hs view
@@ -6,21 +6,7 @@ import GEP.Random import GEP.Types import GEP.Params---- | Fitness function type-type FitnessFunction a b = a -> b -> Double -> Double -> Double---- | Function to express an individual into a list of ET structures-type ExpressionFunction a = Individual -> Genome -> a---- | A test case maps a list of terminals to float values-type TestCase a = SymTable a- --- | A test dictionary is a set of test cases-type TestDict a = [TestCase a]---- | The set of outputs expected for each entry in the test dictionary-type TestOuts = [Double]+import GEP.Fitness {-| Generic driver to be called from specific GEP program instances in their@@ -31,9 +17,9 @@ -> Genome -- ^ Genome that individuals are drawn from -> TestDict b -- ^ Test dictionary for fitness testing -> TestOuts -- ^ Expected test results for test dictionary- -> FitnessFunction a (TestCase b) -- ^ Fitness testing function+ -> FitnessFunction a b -- ^ Fitness testing function -> ExpressionFunction a -- ^ String to ET expression function- -> IO (Double,[String]) -- ^ Return best individual fitness and population+ -> IO (Double, [Chromosome]) -- ^ Return best individual fitness and population gepDriver params rs gnome testdict testouts fitness_evaluate expression_function = do -- create initial population (initialPopulation,rngState) <- return $ runRmonad
GEP/MonadicGeneOperations.hs view
@@ -25,8 +25,8 @@ -} isTransposer :: Genome -> SimParams ->- Individual ->- GEPMonad [Symbol]+ Chromosome ->+ GEPMonad Chromosome isTransposer genome params who = do takelen <- nextR (maxISLen params) takepos <- nextR ((geneLength genome)-takelen)@@ -39,8 +39,8 @@ -} risTransposer :: Genome -> SimParams ->- Individual ->- GEPMonad [Symbol]+ Chromosome ->+ GEPMonad Chromosome risTransposer genome params who = do takelen <- nextR (maxRISLen params) takepos <- nextR ((headLength genome)-1)@@ -51,8 +51,8 @@ Gene transposition helper -} geneTransposer :: Genome ->- Individual ->- GEPMonad [Symbol]+ Chromosome ->+ GEPMonad Chromosome geneTransposer genome who = do whichGene <- nextR (numGenes genome) return $ transposeGene who genome whichGene@@ -63,8 +63,8 @@ resulting individuals after crossover. -} x1PHelper :: Genome ->- (Individual,Individual) ->- GEPMonad (Individual,Individual)+ (Chromosome,Chromosome) ->+ GEPMonad (Chromosome,Chromosome) x1PHelper g pair = do xoverPos <- nextR (geneLength g) return $ crossover1pt pair xoverPos@@ -75,8 +75,8 @@ resulting individuals after crossover. -} x2PHelper :: Genome ->- (Individual,Individual) ->- GEPMonad (Individual,Individual)+ (Chromosome,Chromosome) ->+ GEPMonad (Chromosome,Chromosome) x2PHelper g pair = do xoverPos1 <- nextR (geneLength g) xoverPos2 <- nextRDifferent (geneLength g) xoverPos1@@ -88,8 +88,8 @@ individuals resulting after crossover. -} xGHelper :: Genome ->- (Individual, Individual) ->- GEPMonad (Individual,Individual)+ (Chromosome, Chromosome) ->+ GEPMonad (Chromosome,Chromosome) xGHelper g pair | (numGenes g) == 1 = return pair xGHelper g pair | otherwise = do xoverGene <- nextR (numGenes g)
GEP/Random.hs view
@@ -9,20 +9,18 @@ randomSymbolList, newIndividual, newPopulation,- mutateSymbol, mutate ) where import GEP.Types import GEP.Params import GEP.Rmonad-import System.Random.Mersenne.Pure64 {-| Select a random symbol from the provided list. -}-randomSymbol :: [Symbol] -- ^ List of symbols- -> GEPMonad Symbol-- ^ Selected symbol+randomSymbol :: [a] -- ^ List of symbols+ -> GEPMonad a -- ^ Selected symbol randomSymbol syms = do index <- nextR (length syms) return (syms !! (index-1))@@ -30,9 +28,9 @@ {-| Select a sequence of random symbols from the provided list. -}-randomSymbolList :: [Symbol] -- ^ List of symbols+randomSymbolList :: [a] -- ^ List of symbols -> Int -- ^ Number to select- -> GEPMonad [Symbol] -- ^ List of selected + -> GEPMonad [a] -- ^ List of selected -- symbols randomSymbolList _ 0 = do return [] randomSymbolList syms n =@@ -43,7 +41,7 @@ -- | Generate a new individual given a genome specification. newIndividual :: Genome -- ^ Genome for individual -> Int -- ^ Number of genes to generate- -> GEPMonad Individual+ -> GEPMonad Chromosome newIndividual _ 0 = do return [] newIndividual g n = do hI <- randomSymbolList (allsymbols g) head_len@@ -58,34 +56,39 @@ -- |specification. newPopulation :: Genome -- ^ Genome of population -> Int -- ^ Number of individuals to create- -> GEPMonad [Individual]+ -> GEPMonad [Chromosome] newPopulation _ 0 = do return [] newPopulation g n = do p <- newPopulation g (n-1) i <- newIndividual g (numGenes g) return ([i]++p) -mutateSymbol :: Genome -> Rates -> Symbol -> Double -> Bool -> GEPMonad Symbol-mutateSymbol g r _ p True | (p < (pMutate r)) = - do s <- randomSymbol (allsymbols g)- return s+-- | Mutate symbols in a gene. Symbols are chosen from terminals and allsymbols+-- for head and tail of the gene respectively.+mutateGene :: Genome -> Rates -> Gene -> GEPMonad Gene+mutateGene g r gene = do+ let (h, t) = splitAt (headLength g) gene+ hMutated <- mapM mutateHeadSymbol h+ tMutated <- mapM mutateTailSymbol t+ return $ hMutated ++ tMutated+ where+ mutateTailSymbol :: Symbol -> GEPMonad Symbol+ mutateTailSymbol s = mutateSymbol r s $ terminals g -mutateSymbol g r _ p False | (p < (pMutate r)) =- do s <- randomSymbol (terminals g)- return s+ mutateHeadSymbol :: Symbol -> GEPMonad Symbol+ mutateHeadSymbol s = mutateSymbol r s $ allsymbols g -mutateSymbol _ _ s _ _ | otherwise = - do return s +-- | Mutate single symbol with probability pMutate choosing from given symbol+-- list.+mutateSymbol :: Rates -> Symbol -> [Symbol] -> GEPMonad Symbol+mutateSymbol r s ss =+ nextF 1.0 >>= \prob ->+ if prob < pMutate r+ then randomSymbol ss+ else return s -mutateGene :: Genome -> Rates -> [Symbol] -> GEPMonad [Symbol]-mutateGene_ _ [] = do return []-mutateGene g r (s:ss) =- do prob <- nextF 1.0- news <- mutateSymbol g r s prob ((length ss) >= (tailLength g))- newss <- mutate g r ss- return ([news]++newss) -mutate :: Genome -> Rates -> [Symbol] -> GEPMonad [Symbol]+mutate :: Genome -> Rates -> Chromosome -> GEPMonad Chromosome mutate g r s = do genes' <- mapM (\i -> mutateGene g r i) genes
GEP/Rmonad.hs view
@@ -20,37 +20,27 @@ ) where import System.Random.Mersenne.Pure64-import Control.Monad.State.Strict-import Debug.Trace--newtype Rmonad s a = S (State s a)- deriving (Monad)+import Control.Monad.Mersenne.Random --- | The GEPMonad is just a specific instance of the State monad where the--- state is just the PureMT PRNG state.-type GEPMonad a = Rmonad PureMT a+type GEPMonad a = Rand a -- | Generate a random number as a Double between 0.0 and the given upper -- bound. nextF :: Double -- ^ Upper bound.- -> Rmonad PureMT Double-nextF up = S $ do st <- get- let (x,st') = randomDouble st- put st'- return (x*up)+ -> Rand Double+nextF up = do x <- getDouble+ return (x*up) -- | Generate a random integer between 1 and the upper bound (inclusive). nextR :: Int -- ^ Upper bound.- -> Rmonad PureMT Int-nextR up = S $ do st <- get- let (x,st') = randomInt st- put st'- return (1 + ((abs x) `mod` up))+ -> Rand Int+nextR up = do x <- getInt+ return (1 + ((abs x) `mod` up)) -- | Generate a list of random integers. nextRList :: Int -- ^ Number of integers to generate -> Int -- ^ Upper bound for each integer.- -> Rmonad PureMT [Int]+ -> Rand [Int] nextRList 0 _ = do return [] nextRList n up = do val <- nextR up vals <- nextRList (n-1) up@@ -61,7 +51,7 @@ removeNth (_:xs) 0 = (xs) removeNth (x:xs) n = x:(removeNth xs (n-1)) -shuffle :: [Int] -> Rmonad PureMT [Int]+shuffle :: [Int] -> Rand [Int] shuffle [] = do return [] shuffle x = do val <- nextR $ (length x) rest <- shuffle $ (removeNth x (val-1))@@ -73,7 +63,7 @@ pairify (x:y:xs) = ((x,y):(pairify xs)) -- | Document me!-generatePairs :: Int -> Rmonad PureMT [(Int,Int)]+generatePairs :: Int -> Rand [(Int,Int)] generatePairs 0 = do return [] generatePairs 1 = do return [] generatePairs n = do vals <- shuffle $! [1..n]@@ -81,7 +71,7 @@ -- | Generate a list of n random integers such that each entry occurs at most -- once. Each number in the list must be unique.-nextRListUnique :: Int -> [Int] -> Int -> Rmonad PureMT [Int]+nextRListUnique :: Int -> [Int] -> Int -> Rand [Int] nextRListUnique 0 l _ = do return l nextRListUnique n l up = do val <- nextR up let t = foldr (||) False (map (\i -> i==val) l)@@ -91,7 +81,7 @@ else do ret <- nextRListUnique (n-1) (val:l) up return ret -nextRListPairs :: Int -> Int -> Rmonad PureMT [(Int,Int)]+nextRListPairs :: Int -> Int -> Rand [(Int,Int)] nextRListPairs 0 _ = do return [] nextRListPairs n up = do val1 <- nextR up val2 <- nextRDifferent up val1@@ -102,13 +92,12 @@ -- the integer provided. nextRDifferent :: Int -- ^ Upper bound. -> Int -- ^ Integer to avoid.- -> Rmonad PureMT Int+ -> Rand Int nextRDifferent up x = do x' <- nextR up if x' == x then do x'' <- nextRDifferent up x return x'' else return x' --- | Run function for the Rmonad.-runRmonad :: Rmonad PureMT a -> PureMT -> (a, PureMT)-runRmonad (S m) s = runState m s+runRmonad :: Rand a -> PureMT -> (a, PureMT)+runRmonad = runRandom
GEP/Selection.hs view
@@ -34,8 +34,8 @@ We may return nothing if an empty set is passed in to begin with, so the return type is a Maybe pair. -}-getBest :: [(Double,Individual)] -- ^ Fitness/Individual pairs- -> Maybe (Double,Individual) -- ^ Best pair, or Nothing if no such pair+getBest :: [(Double, Chromosome)] -- ^ Fitness/Individual pairs+ -> Maybe (Double, Chromosome) -- ^ Best pair, or Nothing if no such pair getBest [] = Nothing getBest individuals = let innerBest [] bi bf = Just (bf,bi)
GEP/TimeStep.hs view
@@ -76,9 +76,9 @@ new versions. -} putTogether :: [Int] -- ^ Indices of individuals to replace- -> [Individual] -- ^ Replacement individuals- -> [Individual] -- ^ Original population- -> [Individual] -- ^ New population+ -> [Chromosome] -- ^ Replacement individuals+ -> [Chromosome] -- ^ Original population+ -> [Chromosome] -- ^ New population putTogether indices replacements original = let innerPutTogether cur _ [] [] qs = drop (cur-1) qs innerPutTogether cur _ [] _ qs = drop (cur-1) qs@@ -99,27 +99,97 @@ fillFilterGap :: Genome -> Int -> - [(Double,Individual)] ->- GEPMonad [(Double,Individual)]+ [(Double, Chromosome)] ->+ GEPMonad [(Double, Chromosome)] fillFilterGap genome popsize pop = if (popsize-(length pop)) > 0 then do newIndividuals <- newPopulation genome (popsize-(length pop))- newPop <- return $ map (\i -> (0.0,i)) newIndividuals+ let newPop = map (\i -> (0.0,i)) newIndividuals return $! pop++newPop else return $! pop +applyMutations :: Genome ->+ SimParams ->+ Rates ->+ [Chromosome] ->+ GEPMonad [Chromosome]+applyMutations g params r s = do+ mutated <- mapM (mutate g r) s++ -- IS transposition+ isTransposePop <- nextRListUnique pISCount [] nSelect+ let isPopIn = map (\i -> (!!!) mutated (i-1) "isPopIn") isTransposePop+ isPopOut <- mapM (isTransposer g params) isPopIn+ let isPop = putTogether (sort isTransposePop) isPopOut mutated++ -- RIS transposition+ risTransposePop <- nextRListUnique pRISCount [] nSelect+ let risPopIn = map (\i -> (!!!) isPop (i-1) "risPopIn") risTransposePop+ risPopOut <- mapM (risTransposer g params) risPopIn+ let risPop = putTogether (sort risTransposePop) risPopOut isPop++ -- Gene transposition+ geneTransposePop <- nextRListUnique pGTCount [] nSelect+ let genePopIn = map (\i -> (!!!) risPop (i-1) "genePopIn") geneTransposePop+ genePopOut <- mapM (geneTransposer g) genePopIn+ let genePop = putTogether (sort geneTransposePop) genePopOut risPop++ -- 1Pt crossover+ x1ptPopPairs <- generatePairs nSelect+ let x1ptPopSomePairs = take p1PCount x1ptPopPairs+ let x1UnpairPop = foldr (\(a,b) -> \i -> (a:b:i)) [] x1ptPopSomePairs+ let x1ptPopIn = map (\(a,b) -> ((!!!) genePop (a-1) "x1A",+ (!!!) genePop (b-1) "x1B"))+ x1ptPopSomePairs+ x1ptPopOut <- mapM (x1PHelper g) x1ptPopIn+ let x1ptPopOutFlat = foldr (\(a,b) -> \i -> (a:b:i)) [] x1ptPopOut+ let x1ptPop = putTogether (sort x1UnpairPop) x1ptPopOutFlat genePop++ -- 2Pt crossover+ x2ptPopPairs <- generatePairs nSelect+ let x2ptPopSome = take p2PCount x2ptPopPairs+ let x2UnpairPop = foldr (\(a,b) -> \i -> (a:b:i)) [] x2ptPopSome+ let x2ptPopIn = map (\(a,b) -> ((!!!) x1ptPop (a-1) "x2A",+ (!!!) x1ptPop (b-1) "x2B"))+ x2ptPopSome+ x2ptPopOut <- mapM (x2PHelper g) x2ptPopIn+ let x2ptPopOutFlat = foldr (\(a,b) -> \i -> (a:b:i)) [] x2ptPopOut+ let x2ptPop = putTogether (sort x2UnpairPop) x2ptPopOutFlat x1ptPop++ -- Gene crossover+ xGPopPairs <- generatePairs nSelect+ let xGPopSome = take pGRCount xGPopPairs+ let xGUnpairPop = foldr (\(a,b) -> \i -> (a:b:i)) [] xGPopSome+ let xGPopIn = map (\(a,b) -> ((!!!) x2ptPop (a-1) "xGA",+ (!!!) x2ptPop (b-1) "xGB"))+ xGPopSome+ xGPopOut <- mapM (xGHelper g) xGPopIn+ let xGPopOutFlat = foldr (\(a,b) -> \i -> (a:b:i)) [] xGPopOut+ let xGPop = putTogether (sort xGUnpairPop) xGPopOutFlat x2ptPop++ return xGPop+ where+ nSelect = length s+ fnSelect = intToDouble nSelect+ pISCount = floor (fnSelect * (pIS r))+ pRISCount = floor (fnSelect * (pRIS r))+ pGTCount = floor (fnSelect * (pGT r))+ p1PCount = floor (fnSelect * (p1R r))+ p2PCount = floor (fnSelect * (p2R r))+ pGRCount = floor (fnSelect * (pGR r))+ {-| Single step of GEP algorithm -}-singleStep :: [Individual] -- ^ List of individuals +singleStep :: [Chromosome] -- ^ List of individuals -> Genome -- ^ Genome -> SimParams -- ^ Simulation parameters -> Rates -- ^ Gene operator rates- -> (Individual -> Genome -> a) -- ^ Expression function- -> (a -> b -> Double -> Double -> Double) -- ^ Fitness function- -> [b] -- ^ Fitness inputs- -> [Double] -- ^ Fitness outputs- -> GEPMonad (Double,[Individual])+ -> ExpressionFunction a -- ^ Expression function+ -> FitnessFunction a b-- ^ Fitness function+ -> TestDict b -- ^ Fitness inputs+ -> TestOuts -- ^ Fitness outputs+ -> GEPMonad (Double, [Chromosome]) singleStep pop g params r express_individual fitness_evaluate testInputs testOutputs = do indices <- roulette weights nSelect@@ -127,77 +197,19 @@ filtered <- fillFilterGap g nSelect initialFiltering -- selection- selected <- return $ map (\(_,b) -> b) (selector indices filtered)+ let selected = map (\(_,b) -> b) (selector indices filtered) -- mutation- mutated <- mapM (mutate g r) selected-- -- IS transposition- isTransposePop <- nextRListUnique pISCount [] nSelect- isPopIn <- return $ map (\i -> (!!!) mutated (i-1) "isPopIn") - isTransposePop- isPopOut <- mapM (isTransposer g params) isPopIn- isPop <- return $ putTogether (sort isTransposePop) isPopOut mutated-- -- RIS transposition- risTransposePop <- nextRListUnique pRISCount [] nSelect- risPopIn <- return $ map (\i -> (!!!) isPop (i-1) "risPopIn") - risTransposePop- risPopOut <- mapM (risTransposer g params) risPopIn- risPop <- return $ putTogether (sort risTransposePop) risPopOut isPop-- -- Gene transposition- geneTransposePop <- nextRListUnique pGTCount [] nSelect- genePopIn <- return $ map (\i -> (!!!) risPop (i-1) "genePopIn") - geneTransposePop- genePopOut <- mapM (geneTransposer g) genePopIn- genePop <- return $ putTogether (sort geneTransposePop) genePopOut risPop-- -- 1Pt crossover- x1ptPopPairs <- generatePairs nSelect- x1ptPopSomePairs <- return $ take p1PCount x1ptPopPairs- x1UnpairPop <- return $ foldr (\(a,b) -> \i -> (a:b:i)) [] x1ptPopSomePairs- x1ptPopIn <- return $ map (\(a,b) -> ((!!!) genePop (a-1) "x1A",- (!!!) genePop (b-1) "x1B"))- x1ptPopSomePairs- x1ptPopOut <- mapM (x1PHelper g) x1ptPopIn- x1ptPopOutFlat <- return $ foldr (\(a,b) -> \i -> (a:b:i)) [] x1ptPopOut- x1ptPop <- return $ putTogether (sort x1UnpairPop) x1ptPopOutFlat genePop-- -- 2Pt crossover- x2ptPopPairs <- generatePairs nSelect- x2ptPopSome <- return $ take p2PCount x2ptPopPairs- x2UnpairPop <- return $ foldr (\(a,b) -> \i -> (a:b:i)) [] x2ptPopSome- x2ptPopIn <- return $ map (\(a,b) -> ((!!!) x1ptPop (a-1) "x2A",- (!!!) x1ptPop (b-1) "x2B"))- x2ptPopSome- x2ptPopOut <- mapM (x2PHelper g) x2ptPopIn- x2ptPopOutFlat <- return $ foldr (\(a,b) -> \i -> (a:b:i)) [] x2ptPopOut- x2ptPop <- return $ putTogether (sort x2UnpairPop) x2ptPopOutFlat x1ptPop-- -- Gene crossover- xGPopPairs <- generatePairs nSelect- xGPopSome <- return $ take pGRCount xGPopPairs- xGUnpairPop <- return $ foldr (\(a,b) -> \i -> (a:b:i)) [] xGPopSome- xGPopIn <- return $ map (\(a,b) -> ((!!!) x2ptPop (a-1) "xGA",- (!!!) x2ptPop (b-1) "xGB"))- xGPopSome- xGPopOut <- mapM (xGHelper g) xGPopIn- xGPopOutFlat <- return $ foldr (\(a,b) -> \i -> (a:b:i)) [] xGPopOut- xGPop <- return $ putTogether (sort xGUnpairPop) xGPopOutFlat x2ptPop+ resultingPop <- applyMutations g params r selected --- return $ (trace (bestIndividual++" => "++(show bestFitness)++" AVG="++(show avgFitness)) (bestFitness,[bestIndividual]++x2ptPop))- return $ (trace ((show bestFitness)++" "++(show avgFitness)) (bestFitness,[bestIndividual]++xGPop))+ (bestFitness, bestIndividual) <- case best of+ Just (f, i) -> return (f, i)+ Nothing -> do newI <- newIndividual g (numGenes g)+ return (0.0, newI)+-- return $ (trace (bestIndividual++" => "++(show bestFitness)++" AVG="++(show avgFitness)) (bestFitness,[bestIndividual]++resultingPop))+ return $ (trace ((show bestFitness)++" "++(show avgFitness)) (bestFitness,[bestIndividual]++resultingPop)) where- nPop = length pop- nSelect = nPop - 1- fnSelect = intToDouble nSelect- pISCount = floor (fnSelect * (pIS r))- pRISCount = floor (fnSelect * (pRIS r))- pGTCount = floor (fnSelect * (pGT r))- p1PCount = floor (fnSelect * (p1R r))- p2PCount = floor (fnSelect * (p2R r))- pGRCount = floor (fnSelect * (pGR r))+ nSelect = length pop - 1 expressedPop = map (\i -> express_individual i g) pop fitnesses = map (\i -> fitness_tester i (fitness_evaluate) @@ -211,22 +223,21 @@ (intToDouble (length initialFiltering)))) 0.0 initialFiltering best = getBest initialFiltering- Just (bestFitness,bestIndividual) = best weights = generate_roulette_weights (intToDouble (length initialFiltering)) (rouletteExponent params) -multiStep :: [Individual] -- ^ List of individuals+multiStep :: [Chromosome] -- ^ List of individuals -> Genome -- ^ Genome -> SimParams -- ^ Simulation parameters -> Rates -- ^ Gene operator rates- -> (Individual -> Genome -> a) -- ^ Expression function- -> (a -> b -> Double -> Double -> Double) -- ^ Fitness function- -> [b] -- ^ Fitness inputs- -> [Double] -- ^ Fitness outputs+ -> ExpressionFunction a -- ^ Expression function+ -> FitnessFunction a b -- ^ Fitness function+ -> TestDict b -- ^ Fitness inputs+ -> TestOuts -- ^ Fitness outputs -> Int -- ^ Maximum number of generations to test -> Double -- ^ Ideal fitness- -> GEPMonad (Double,[Individual])+ -> GEPMonad (Double, [Chromosome]) multiStep pop g params r expresser fitnesser tests outs 0 _ = do (bf,newp) <- singleStep pop g params r expresser fitnesser tests outs return (bf,newp)
GEP/Types.hs view
@@ -7,10 +7,11 @@ -- * Types Genome(..), Symbol,+ Sequence, Gene, Chromosome,- Individual, SymTable,+ ExpressionFunction, -- * Functions tailLength,@@ -24,16 +25,17 @@ -- | A symbol in a chromosome type Symbol = Char +-- | A sequence of symbols not neccessaryly a gene or chromosome. Used in gene+-- operations.+type Sequence = [Char]+ -- | A gene in a chromosome is a list of symbols-type Gene = [Symbol]+type Gene = Sequence -- | A chromosome is a list of symbols. We avoided using a list of genes to -- maintain the view of a chromosome as nothing more than a flattened, -- linear sequence of genes.-type Chromosome = [Symbol]---- | An individual is a chromosome-type Individual = Chromosome+type Chromosome = Sequence -- | Symbol table used for fitness tests. We assume that there is exactly -- one pair per symbol. If there are symbols missing, fitness testing@@ -41,6 +43,9 @@ -- default values). If a symbol occurs multiple times in the symbol -- table, no guarantee is provided for which value will be chosen. type SymTable a = [(Symbol,a)]++-- | Function to express an individual into a list of ET structures+type ExpressionFunction a = Chromosome -> Genome -> a -- | Data type representing a genome. The genome contains all necessary -- parameters to interpret a chromosome. These include the alphabet (split
HSGEP.cabal view
@@ -1,5 +1,5 @@ Name: HSGEP-Version: 0.1.0+Version: 0.1.1 Cabal-Version: >= 1.6 License: BSD3 License-File: LICENSE@@ -16,14 +16,24 @@ Extra-Source-Files: Examples/Regression/*.in Examples/Regression/*.csv README README_Params.txt Library- Build-Depends: base>=4&&<5, random, mtl, parsec>=2&&<3, network, haskell98, mersenne-random-pure64+ GHC-Options: -Wall+ GHC-Prof-Options: -Wall -auto-all -caf-all++ Build-Depends: base>=4&&<5, mtl, haskell98, mersenne-random-pure64, monad-mersenne-random, vector Exposed-modules: GEP.Fitness, GEP.GeneOperations, GEP.MonadicGeneOperations, GEP.Params, GEP.Random, GEP.Rmonad, GEP.TimeStep, GEP.Selection, GEP.Util.ConfigurationReader,- GEP.Types, GEP.GenericDriver, GEP.Examples.Regression.FitnessInput,- GEP.Examples.Regression.ArithmeticIndividual+ GEP.Types, GEP.GenericDriver Executable HSGEP_Regression+ GHC-Options: -Wall+ GHC-Prof-Options: -Wall -auto-all -caf-all++ Build-Depends: network, csv Main-Is: GEP/Examples/Regression/Driver.hs++Executable HSGEP_CADensity+ Buildable: False+ Main-Is: GEP/Examples/CADensity/Driver.hs
README view
@@ -1,10 +1,17 @@ ==================================================== = HSGEP: Gene Expression Programming in Haskell =-= Version 0.1 =+= Version 0.1.1 = = Author: Matthew Sottile (mjsottile@computer.org) = ==================================================== ** This code is released under the BSD3 Open Source License **++0.0: Credits+------------++Contributors:+ - Matthew Sottile (mjsottile@computer.org)+ - Dmitrij Naumov 1.0: Introduction -----------------