module Chromosome.GP (Op (..),
Node (..),
mseFitness,
mutate,
eval,
random,
config)
where
import Array
import qualified GA
import Control.Monad.State.Strict
import List
config = GA.ChromosomeConfig {
GA.mutate = undefined,
GA.cross = undefined,
GA.fitness = undefined
}
data Op a s = Op {
callback :: ([a] -> State s a),
arity :: Int,
name :: String
}
instance Show (Op a s) where
show = name
data Node a s = Node (Op a s) [Node a s]
instance Show (Node a s) where
show (Node o children) =
if arity o == 0
then show o
else "(" ++ (unwords $ show o : map show children) ++ ")"
mseFitness :: (Fractional a) => [(s, a)] -> Node a s -> a
mseFitness examples node =
1.0 / (mse node examples + 1.0)
mse :: (Fractional a) => Node a s -> [(s, a)] -> a
mse node examples =
average $ map (^2) $ map (\(i,o) -> delta node i o) examples
delta node state output =
output (evalState (eval node) state)
eval :: Node a s -> State s a
eval (Node (Op f _ _) ns) =
mapM eval ns >>= f
mutate 0 ops rate tree = error "Attempt to mutate with depth of 0"
mutate d ops rate tree@(Node op children) = do
test <- GA.gaRand (0.0, 1.0)
if test >= rate
then do newChildren <- mapM (mutate (d1) ops rate) children
return $ Node op newChildren
else random d ops
random 0 ops = error "Attempt to create depth 0 tree"
random 1 ops = do
op <- randomOp $ filter ((==0) . arity) ops
return $ Node op []
random d ops = do
op <- randomOp ops
children <- replicateM (arity op) $ random (d1) ops
return $ Node op children
randomOp ops =
GA.gaRand (0,length ops 1) >>=
return . (ops !!)
average xs = sum xs / genericLength xs