Genetic Programming Framework in Haskell (incomplete)

GP.hs

{-# OPTIONS -Wall #-} 

import Data.Map (Map, findWithDefault, fromList)
import LinReg (testData)
import Test.QuickCheck
import Test.QuickCheck.Gen
import System.Random
import GHC.Exts (sortWith)

data AST = Add AST AST
		| Mul AST AST
		| Number Float
		| Var String
		deriving Show

type Genotype = AST
type Indiv = Genotype
type Population = [Indiv]
type Env = Map String Float

var :: String -> Env -> Float
var = findWithDefault 0.0

eval :: AST -> Env -> Float
eval (Number n) _ = n
eval (Add a b) e = (eval a e) + (eval b e)
eval (Mul a b) e = (eval a e) * (eval b e)
eval (Var s) e = var s e

phenotype :: Genotype -> (Env -> Float)
phenotype = eval

calc :: Float -> Indiv -> Float
calc n ind = phenotype ind $ fromList [("a", n)]
	
fitness :: Indiv -> Float
fitness ind = sum [  j - (calc i ind) | (i,j) <- testData ]

instance Arbitrary AST
  where arbitrary = do
	a <- arbitrary :: Gen Float
	b <- arbitrary :: Gen AST
	c <- arbitrary :: Gen AST
	x <- oneof [  return (Var "a"), 
				  return (Number a), 
				  return (Add b c),
				  return (Mul b c) ]
	return x

randomPop :: StdGen -> Population
randomPop g = take 10 $ repeat $ randomIndiv g
	where randomIndiv j = unGen arbitrary j 9999999

bestOf :: Population -> Int-> Population
bestOf p n = take n $ sorted p
	where sorted = sortWith fitness

selfZip :: [a] -> [(a,a)]
selfZip l = zip a b
	where a = take (length a `div` 2) l;
		b = drop (length a `div` 2) l

crossover :: (Indiv, Indiv) -> [Indiv]
crossover (a, b) = [a] ++ [b]

cross :: Population -> Population
cross x = foldl1 (++) $ map (crossover) (selfZip x)
	

mutation :: Indiv -> Indiv
mutation i = i

mutate :: Population -> Population
mutate = map mutation

iteration :: Population -> Population
iteration p = mutate $ (cross $ bestOf p 10) ++ ( bestOf p 20)

run :: Population -> Indiv
run p = head $ bestOf lastPop 1
	where lastPop = last $ take 100 $ iterate iteration p

main :: IO ()
main = do
		initPop <- return $ randomPop (mkStdGen seed)
		print $ "Best Indiv: " ++ (show $ run initPop)
	where seed = 12352

LinReg.hs

module LinReg (testData) where

testData :: [(Float, Float)]
testData = [
	(1, 9), 
	(2, 8),
	(3, 7),
	(4, 6),
	(5, 5),
	(6, 4),
	(7, 3),
	(8, 2),
	(9, 1)
	]