diff --git a/Examples/Regression/test3.in b/Examples/Regression/test3.in --- a/Examples/Regression/test3.in +++ b/Examples/Regression/test3.in @@ -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 diff --git a/Examples/Regression/test6.csv b/Examples/Regression/test6.csv new file mode 100644 --- /dev/null +++ b/Examples/Regression/test6.csv @@ -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 diff --git a/Examples/Regression/test6.in b/Examples/Regression/test6.in new file mode 100644 --- /dev/null +++ b/Examples/Regression/test6.in @@ -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 diff --git a/GEP/Examples/CADensity/Driver.hs b/GEP/Examples/CADensity/Driver.hs new file mode 100644 --- /dev/null +++ b/GEP/Examples/CADensity/Driver.hs @@ -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 diff --git a/GEP/Examples/Regression/ArithmeticIndividual.hs b/GEP/Examples/Regression/ArithmeticIndividual.hs deleted file mode 100644 --- a/GEP/Examples/Regression/ArithmeticIndividual.hs +++ /dev/null @@ -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 diff --git a/GEP/Examples/Regression/Driver.hs b/GEP/Examples/Regression/Driver.hs --- a/GEP/Examples/Regression/Driver.hs +++ b/GEP/Examples/Regression/Driver.hs @@ -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 diff --git a/GEP/Examples/Regression/FitnessInput.hs b/GEP/Examples/Regression/FitnessInput.hs deleted file mode 100644 --- a/GEP/Examples/Regression/FitnessInput.hs +++ /dev/null @@ -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 --} diff --git a/GEP/Fitness.hs b/GEP/Fitness.hs --- a/GEP/Fitness.hs +++ b/GEP/Fitness.hs @@ -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) diff --git a/GEP/GeneOperations.hs b/GEP/GeneOperations.hs --- a/GEP/GeneOperations.hs +++ b/GEP/GeneOperations.hs @@ -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) diff --git a/GEP/GenericDriver.hs b/GEP/GenericDriver.hs --- a/GEP/GenericDriver.hs +++ b/GEP/GenericDriver.hs @@ -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 diff --git a/GEP/MonadicGeneOperations.hs b/GEP/MonadicGeneOperations.hs --- a/GEP/MonadicGeneOperations.hs +++ b/GEP/MonadicGeneOperations.hs @@ -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) diff --git a/GEP/Random.hs b/GEP/Random.hs --- a/GEP/Random.hs +++ b/GEP/Random.hs @@ -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 diff --git a/GEP/Rmonad.hs b/GEP/Rmonad.hs --- a/GEP/Rmonad.hs +++ b/GEP/Rmonad.hs @@ -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 diff --git a/GEP/Selection.hs b/GEP/Selection.hs --- a/GEP/Selection.hs +++ b/GEP/Selection.hs @@ -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) diff --git a/GEP/TimeStep.hs b/GEP/TimeStep.hs --- a/GEP/TimeStep.hs +++ b/GEP/TimeStep.hs @@ -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) diff --git a/GEP/Types.hs b/GEP/Types.hs --- a/GEP/Types.hs +++ b/GEP/Types.hs @@ -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 diff --git a/HSGEP.cabal b/HSGEP.cabal --- a/HSGEP.cabal +++ b/HSGEP.cabal @@ -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 diff --git a/README b/README --- a/README +++ b/README @@ -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 -----------------