Commit 435f60aa authored by Michal Terepeta's avatar Michal Terepeta Committed by Ben Gamari

real: remove PolyGP

The benchmark doesn't compile and was not enabled. I tried fixing it,
but it seems to take excessive amount of time & memory (didn't finish
in 60s, which required over 10GiB of RAM). Sounds like another
candidate for removal.
Signed-off-by: Michal Terepeta's avatarMichal Terepeta <michal.terepeta@gmail.com>

Test Plan: build & run

Reviewers: bgamari

Differential Revision: https://phabricator.haskell.org/D3329
parent 313812d3
......@@ -5,7 +5,6 @@ SUBDIRS = anna bspt cacheprof compress compress2 fem fluid fulsom gamteb gg \
grep hidden hpg infer lift linear maillist mkhprog parser pic prolog \
reptile rsa scs symalg veritas
OTHER_SUBDIRS = PolyGP
include $(TOP)/mk/target.mk
{---------------------------------------------------------------
--
-- Auxil.hs : contains supporting function defination for the system.
-- T.Yu@cs.ucl.ac.uk September 25, 1997
--
--------------------------------------------------------------}
module Auxil where
import Local(args,retType,testData,myName,expectResults,maxScore,evalFitness,printFitness)
import Header(TypeExp(..),ParseTree(..),Expression(..),Population(..))
import Create(createTree,extract)
import Evolve(mutateExp,xOverExp)
import Eval(evalExp,atoi,atof)
import Unify(applySubToExp,unify)
import Trace
-- getParas function -----------------------------------------------------------------------------
--
getParas :: String -> Int -> Int -> Int -> Int -> Double -> Int -> (Int, Int, Int, Int, Double, Int)
getParas inputs treeDepth popSize randomInt maxEval parScale xOverRate =
case inputs of
{
[] -> (treeDepth, popSize, randomInt, maxEval, parScale, xOverRate);
_ ->
let (current, rest)= nextWord inputs []
(value,rest') = nextWord rest []
in if current == "treeDepth=" then
getParas rest' (atoi value) popSize randomInt maxEval parScale xOverRate
else if current == "popSize=" then
getParas rest' treeDepth (atoi value) randomInt maxEval parScale xOverRate
else if current == "randomInt=" then
getParas rest' treeDepth popSize (atoi value) maxEval parScale xOverRate
else if current == "maxEval=" then
getParas rest' treeDepth popSize randomInt (atoi value) parScale xOverRate
else if current == "parScale=" then
getParas rest' treeDepth popSize randomInt maxEval (atof value) xOverRate
else
getParas rest' treeDepth popSize randomInt maxEval parScale (atoi value)
}
-- nextWord --------------------------------------------------------------------------
--
nextWord :: String -> String -> (String,String)
nextWord [] word = error "Parameter inputs empty."
nextWord (x:xs) word = if x `elem` ['\n', '\r', ' '] then (word, xs) else nextWord xs (word ++ [x])
--create function-----------------------------------------------------------------------------------------------
--
--This function creates population with specified popSize. It checks to make sure that
-- every tree created is unique. Each individual is a lambada Expression.
--
create :: Int -> Population -> [Int] -> Int -> (Population,[Int])
create num pop rList treeDepth =
--trace ("num is : " ++ show num) $
case num of
{
0 -> trace ("create: top fitness is: "++show (snd (head pop))) $
(pop,rList);
_ -> case (createTree treeDepth retType rList [] 1) of
{ (aTree, rList', theta, typeNum') ->
let exp = applySubToExp (extract aTree) theta
createProgram exp args =
case args of
{ [] -> exp;
(hdArg:tlArgs) -> createProgram (Lambda hdArg exp) tlArgs
}
program = createProgram exp args
in
if ( aMem program pop) || (notExist args program) || (not (exist (Function myName) program ))
then
create num pop rList' treeDepth
else
if (num `mod` printFitness) == 0 && not (null pop) then
trace ("create: top fitness is: "++show (snd (head pop))) $
create (num-1) (inSort(getFitness (program, 0.0) [(myName,program)] args testData
expectResults) pop) rList' treeDepth
else
create (num-1) (inSort(getFitness (program, 0.0) [(myName,program)] args testData
expectResults) pop) rList' treeDepth
}
}
--exist function-----------------------------------------------------------------------
--
exist :: Expression -> Expression -> Bool
exist e exp = case exp of
{
(Application exp1 exp2 t) ->
if exist e exp1 then True
else exist e exp2;
(Lambda s exp) ->
exist e exp;
_ -> if e == exp then True else False
}
notExist [] program = False
notExist (first:rest) program = if not (exist (Variable first) program) then True
else
notExist rest program
-- aMem function--------------------------------------------------------------------
--
aMem :: Expression -> Population -> Bool
aMem exp1 exp2 = case exp2 of
{
[] -> False;
((aExp,fitness):rest) ->
if exp1 == aExp then True
else aMem exp1 rest
}
-- getFitness function---------------------------------------------------------------------
--
-- This function takes 5 arguments: the name of an expression, the expression and it's original
-- fitness value, argument name list and testData. It appends test data into expression before
-- evaluation.
getFitness :: (Expression,Double) -> [(String,Expression)] -> [String] -> [Expression] -> [Expression] -> (Expression,Double)
getFitness (tree, fitness) adfs args [] expectResults = (tree, fitness)
getFitness (tree, fitness) adfs args testData expectResults =
if fitness == 10000.00 then (tree, 20000.00) else -- 10000 means bug in the evolved program
let createProgram exp (last:[]) ((List aList):tlData) expectResults =
(Application exp (List aList) IntNum, tlData, length aList ,
(head expectResults), (tail expectResults))
createProgram exp (hdArg:tlArgs) (hdData:tlData) expectResults =
createProgram (Application exp hdData IntNum) tlArgs tlData expectResults -- IntNum type is wrong
createProgram exp [] testData expectResults = error "No Argument variable is provided."
createProgram exp args [] expectResults = error "No test data is provided."
(program, testData', recursionLimit, theResult, expectResults') =
createProgram tree args testData expectResults
(aResult,rtError,halt,debug) = evalExp program adfs recursionLimit False True False
in
--(tree,(aResult,rtError),0.0)
--trace ("getFitness : "++ show program ++ show testData'++show recursionLimit) $
if debug then
(tree,10000.00)
else
getFitness (tree,(evalFitness theResult aResult rtError halt + fitness )) adfs args testData' expectResults'
-- inSort function ---------------------------------------------------------------
--
inSort :: (Expression,Double) -> Population -> Population
inSort exp [] = exp:[]
inSort (exp1,fitness1)((exp2,fitness2):rest) =
if fitness1 < fitness2 then
(exp2,fitness2):inSort (exp1,fitness1) rest
else
(exp1,fitness1):((exp2,fitness2):rest)
--evolve function --
-- steady-stead with
evolve :: Population -> Int -> Double -> Int -> Int -> Int -> [Double] -> [Int] -> (Population,[Double],[Int])
evolve [] maxEval parScale popSize treeDepth xOverRate dList rList = error "Empty population."
evolve pop@((exp,fitness):rest) maxEval parScale popSize treeDepth xOverRate dList rList =
if fitness >= maxScore then
trace ("The perfect score in pop: "++show fitness++show exp)$
(pop,dList,rList)
else
case maxEval of
{ 0 -> (pop,dList,rList);
_ ->
let popSizeInReal = fromInteger (toInteger popSize)
selValue dList = ((head dList) * popSizeInReal * (parScale ^ popSize) * ( 1.0 - parScale ^ popSize) /
(parScale ^ popSize * (1.0 - parScale)), tail dList)
selIndex currVal randomVal | randomVal <= currVal = 0 -- 0-origin
| otherwise = 1 + selIndex (currVal*parScale) (randomVal - currVal)
getIndex aSeed = let i = selIndex popSizeInReal aSeed in if i < popSize then i else (popSize -1)
(seed1,dList') = selValue dList
parent1 = pop !! (getIndex seed1)
(seed2,dList'') = selValue dList'
(firstBorn,theta, rList')
= if (maxEval `mod` 1000 ) < xOverRate then
xOverExp (fst parent1) (fst ( pop !! (getIndex seed2))) treeDepth treeDepth rList
else
mutateExp (fst parent1) treeDepth treeDepth rList
in
if (aMem firstBorn pop) || (notExist args firstBorn) || (not (exist (Function myName) firstBorn ))
then
evolve pop maxEval parScale popSize treeDepth xOverRate dList'' rList'
else
let (child,fitness) = getFitness (firstBorn,0.00)
[(myName,firstBorn)] args testData expectResults
pop' = inSort (child,fitness) pop
pop'' = init pop'
in
if fitness >= maxScore then
trace ("The number of evaluation done is the parameter maxEval - "++show maxEval++show "\n"++show parent1++show "\n"++show (pop !! (getIndex seed2))) $
(pop'',dList'',rList')
else if ((maxEval-1) `mod` printFitness) == 0 then
trace ("evolve: top fitness is: "++show (snd (head pop))) $
evolve pop'' (maxEval-1) parScale popSize treeDepth xOverRate dList'' rList'
else
evolve pop'' (maxEval-1) parScale popSize treeDepth xOverRate dList'' rList'
}
displayPop :: Int -> Population -> IO ()
displayPop num pop =
case (num,pop) of
{
(_,[]) -> print "Population empty";
(0,_) -> print "Done";
(_,_ ) ->
print (head pop) >>
putChar '\n' >>
displayPop (num - 1 ) (tail pop)
}
--indexL function--
indexL item aList =
case aList of
{
[] -> 0 ;
(hd:tl) -> if item == hd then 1
else ( 1 + indexL item tl)
}
{---------------------------------------------------------------
--
-- Create.hs : contains function defination to generate program
-- parse trees.
-- T.Yu@cs.ucl.ac.uk September 25, 1997
--
--------------------------------------------------------------}
module Create (createTree,extract)where
import Header (TypeExp(..), Expression(..),ParseTree(..))
import Local (termEnv,funEnv,constant,adfs,args)
import Unify (applySub, unify, Theta(..))
import Data.Array
-- selectTerm function -----------------------------------------------------------------
--
-- This function takes a type expression, a theta, a randomList and typeNum. It return a tuple
-- of the following elements: flag indicates whether a terminal is selected, the name
-- of the terminal, theta created, new random list and new typeNum.
-- If the expected retrun type contains temporary tyep variables,
-- we first instaniate dummy type variables in the selected terminal type
-- with new temporary type variables before "unifying" it with the return
-- type.
selectTerm :: TypeExp -> Theta -> [Int] -> Int -> (Bool, String,Theta, [Int], Int)
selectTerm retType theta rList typeNum =
let (start, end) = bounds termEnv
index = (head rList `mod` end) + start
match currIndex init =
if not init && (currIndex == index) then
(False, "", theta, tail rList, typeNum)
else if currIndex > end then
match start init
else
case ( termEnv ! currIndex ) of
{
(name,typeSig) ->
if hasTypeVar retType then
case (instDummy typeSig typeNum []) of
{
(typeSig', typeNum', dummyTheta) ->
case unify True [(retType, typeSig')] theta of
{
(unifiable, theta') ->
if unifiable then
(True, name, theta', tail rList, typeNum')
else
match (currIndex +1) False
}
}
else
case ( unify True [(retType,typeSig)][] ) of
{
(unifiable, theta') ->
if unifiable then
(True, name, theta, tail rList, typeNum)
else
match (currIndex +1) False
}
}
in
match index True
-- selectFun function -----------------------------------------------------------------
--
-- This function takes a type expression, a theta, first and last index and typeNum.
-- It return a tuple of the following elements: flag indicates whether a function is selected,
-- the name of the function, its argument type signatuer, theta created, index of the function
-- and new typeNum.
-- If the expected retrun type contains temporary tyep variables,
-- we first instaniate dummy type variables in the selected function type
-- with new temporary type variables before "unifying" it with the return
-- type.
selectFun :: TypeExp -> Theta -> Int -> Int -> Int -> (Bool, String, TypeExp, Theta, Int, Int)
selectFun retType theta first last typeNum =
--trace("selectFun : " ++ show first ++ show last ) $
let (start, end) = bounds funEnv
match currIndex init =
if not init && (currIndex == last) then
(False, "", retType, theta, first, typeNum) -- retType means nothing
else if currIndex > end then
match start init
else
let (name,typeSig) = funEnv ! currIndex
in if hasTypeVar retType then
let (typeSig', typeNum', dummyTheta) = instDummy typeSig typeNum []
(unifiable, argsType,theta') = getArgsType retType typeSig' theta
in
if unifiable then
(True, name, argsType, theta', currIndex, typeNum')
else
match (currIndex +1) False
else
let (unifiable, argsType,theta') = getArgsType retType typeSig []
in if unifiable then
let (argsType', typeNum', dummyTheta) = instDummy argsType typeNum []
in (True, name, argsType', theta, currIndex, typeNum')
else
match (currIndex + 1) False
in
match first True
-- instDummy function -----------------------------------------------------------------------
--
-- This fucntion takes a type expression and instantiates all dummy type variables with
-- temporary type variables. It returns the new type expression and new TypeNum
instDummy :: TypeExp -> Int -> Theta -> (TypeExp,Int,Theta)
instDummy typeExp typeNum theta =
case typeExp of
{
(DummyType x) -> let typeExp' = TypeVar ("T"++show typeNum)
in (typeExp',(typeNum + 1),(x,typeExp'):theta);
(Arrow t1 t2) -> let (t1', typeNum', theta') = instDummy t1 typeNum theta
(t2', typeNum'', theta'') = instDummy (applySub theta' t2) typeNum' theta'
in (Arrow t1' t2', typeNum'', theta'');
(Brackets t) -> let (t', typeNum', theta') = instDummy t typeNum theta
in (Brackets t',typeNum', theta');
(ListType t) -> let (t', typeNum', theta') = instDummy t typeNum theta
in (ListType t',typeNum', theta');
_ -> (typeExp, typeNum, theta)
}
-- hasTypeVar function ---------------------------------------------------------
--
--
hasTypeVar :: TypeExp -> Bool
hasTypeVar typeExp =
case typeExp of
{
(TypeVar _) -> True;
(Arrow t1 t2) -> (hasTypeVar t1) || (hasTypeVar t2);
(Brackets t) -> hasTypeVar t;
(ListType t) -> hasTypeVar t;
_ -> False
}
-- createTree function ----------------------------------------------------------
--
-- This function takes 6 arguments: a depth level, return type, randomList, theta typeNum and genTypes.
-- It returns a ParseTree with the specifed depth and return type.
-- We basically use "full" method unless no non-terminal to match the required type.
-- In that case, we pick a terminal and stop growing.
createTree :: Int -> TypeExp -> [Int] -> Theta -> Int -> ( ParseTree, [Int], Theta, Int)
createTree 1 retType rList theta typeNum =
--trace ("create1 "++show retType++show theta) $
let retType' = applySub theta retType
(findOne, name, theta', rList', typeNum') = selectTerm retType' theta rList typeNum
in
--trace ("selectTerm: "++show name++show theta') $
if not findOne then -- fail, no variable that matches the return type
(Empty, rList, theta, typeNum)
else
if (elem name constant) then
(ExpCons (Constant name), rList', theta', typeNum')
else
if name == "nil" then
(ExpCons (List []), rList', theta', typeNum')
else
(ExpCons (Variable name), rList', theta', typeNum')
createTree level retType rList theta typeNum =
--trace ("create "++show level++show retType++show theta) $
let retType' = applySub theta retType
(start, end) = bounds funEnv
orgIndex = (head rList `mod` end) + start
in
--trace ("info: "++show retType'++show start++show end++show orgIndex) $
let f1 first last init rList =
if not init && (first == last) then
createTree 1 retType' rList theta typeNum -- create leaf ( grow method )
else
let (findOne, name, argsType, theta', index, typeNum')=
selectFun retType' theta first last typeNum
in
--trace ("selectFun: "++show findOne++show name++show argsType++show theta'++show index) $
if not findOne then -- fail, no function matches the return type,
createTree 1 retType' rList theta typeNum -- create leaf ( grow method )
else
let f2 argType retType rList theta typeNum =
case argType of
{
(Arrow t1 t2) ->
let getRetType t =
case t of
{
(Arrow t1 s@(Arrow t2 t3)) ->
let (aType, rType)= getRetType s
in (Arrow t1 aType, rType);
(Arrow t1 t2) -> (t1,t2)
}
(argType', newRetType) = getRetType argType
(exp2, rList', theta', typeNum') =
createTree (level-1) newRetType rList theta typeNum
in if exp2 == Empty then
(Empty,Empty,rList',[],typeNum')
else
let argType'' = applySub theta' argType'
newRetType' = applySub theta' newRetType
(exp1', exp2',rList'',theta'',typeNum'') =
f2 argType'' (Arrow newRetType' retType) rList' theta' typeNum'
in if (exp1'==Empty) || (exp2'==Empty) then
(Empty,Empty,rList'',[],typeNum'')
else
(ExpCons (Application (extract exp1') (extract exp2')
(Arrow (applySub theta'' newRetType')
(applySub theta'' retType))), exp2, rList'', theta'', typeNum'');
_ -> case (createTree (level-1) argType rList theta typeNum) of
{
(exp2,rList',theta',typeNum') ->
if exp2 == Empty then
(Empty, Empty, rList, [], typeNum)
else
if (elem name adfs) then
( ExpCons(Function name), exp2, rList', theta', typeNum')
else
if (elem name args ) then
( ExpCons (Variable name), exp2, rList', theta', typeNum')
else
( ExpCons(Primitive name), exp2, rList', theta', typeNum')
}
}
in
--trace ("f1 in "++show name++show argTypes++show retType'++show newTheta) $
case (f2 argsType retType' rList theta' typeNum') of
{
(exp1, exp2, rList', theta'', typeNum'') ->
if (exp1==Empty) || (exp2==Empty) then
f1 (index +1) last False rList'
else
(ExpCons (Application (extract exp1)(extract exp2) retType'), rList', theta'', typeNum'')
}
in
f1 orgIndex orgIndex True (tail rList)
-- getArgsType function ----------------------------------------------------------------
--
-- This function takes an expected type and a function type. It unify the expected type
-- with the function return type. It then instaniate the argument type using the theta.
-- It returns the instantiated argument type.
getArgsType :: TypeExp -> TypeExp -> Theta -> (Bool, TypeExp, Theta)
getArgsType retType typeExp theta =
let unifyRetType aType theta = case aType of
{
(Arrow argType rType) -> unifyRetType rType theta;
_ -> unify True [(retType,aType)] theta
}
(unifiable,theta') = unifyRetType typeExp theta
in if unifiable then
let typeExp' = applySub theta' typeExp
retType' = applySub theta' retType
f exp = case exp of
{
(Arrow t1 t2) -> if t2 == retType' then t1
else (Arrow t1 (f t2));
_ -> error ("error in getArgsType ")
}
in
(True, (f typeExp'), theta')
else
(False, typeExp, theta)
--no need to deal with arrow situation since functions are curried
--extract -----------------------------------------------------------------------------
extract :: ParseTree -> Expression
extract exp = case exp of
{
Empty -> error "Empty expression";
(ExpCons x) -> x
}
{---------------------------------------------------------------
--
-- Eval.hs : contains function definition which evaluate/interpret
-- the genetic programs evolved by the system.
-- T.Yu@cs.ucl.ac.uk September 25, 1997
--
--------------------------------------------------------------}
module Eval (evalExp,atoi,atof) where
import Header(TypeExp(..), Expression(..))
import Local(runTimeErrorHandler)
import Data.Char(ord)
import Trace
--evalExp function---------------------------------------------------------------
--
-- This function takes 3 arguments : an expression, an adf list and counter.
-- It evaluates the expression and return its result, an expression. The counter
-- is used to check for recursive calls.
evalExp:: Expression -> [(String,Expression)] -> Int -> Bool -> Bool -> Bool -> (Expression,Bool,Bool,Bool)
evalExp exp adfs counter rtError halt debug =
case exp of
{
(Constant x) -> (exp, rtError, halt,debug);
(List x) -> (exp, rtError, halt,debug);
(Variable x) -> (exp, rtError, halt,debug);
(Primitive x) -> (exp, rtError, halt,debug);
(Function x) -> (exp, rtError, halt ,debug);
(Lambda x e) -> (exp, rtError, halt,debug);
-- head,tail,null (strict)
(Application (Primitive f) arg t) ->
--trace ("Primitive1 : "++ show f ++ show arg ) $
if (not halt) || debug then
(errorHandler t, rtError, halt, debug)
else
doPrim1 f arg t adfs counter rtError True False;
--+,-,==,cons(non-strict)
(Application (Application (Primitive f) arg1 t1) arg2 t2) ->
--trace ("Primitive2 : "++ show f ++ show arg1 ++ show arg2) $
if (not halt) || debug then
(errorHandler t2, rtError, halt, debug)
else
doPrim2 f arg1 arg2 t2 adfs counter rtError True False;
--if-then-else (1st arg strict)
(Application (Application (Application (Primitive f) arg1 t1 ) arg2 t2 ) arg3 t3) ->
--trace ("Primitive3 : "++ show f ++ show arg1 ++ show arg2 ++ show arg3) $
if (not halt) || debug then
(errorHandler t3, rtError, halt, debug)
else
doPrim3 f arg1 arg2 arg3 t3 adfs counter rtError True False;
--applicative-order reduction
(Application (Lambda x e) y t) ->
--trace ("Lambda "++ show x ++ show e ++ show y) $
if (not halt) || debug then
(errorHandler t, rtError, halt, debug)
else
case (evalExp y adfs counter rtError True False) of
{ (y', rtError', halt',debug') ->
if (not halt') || debug' then
(errorHandler t,rtError',True, False)
else
evalExp (betaReduction y' x e) adfs counter rtError' True False
};
--normal-order reduction (app (app (lambda f.lambda l e) aF) aL)
(Application (Application (Lambda f e) aF t1) aL t2) ->
--trace ("Lambda "++ show f ++ show e ++ show aF ++ show aL) $
if (not halt) || debug then
(errorHandler t2 ,rtError, halt, debug)
else
case (evalExp aF adfs counter rtError True False) of
{ (aF',rtError', halt',debug') ->
if (not halt') || debug' then
(errorHandler t2, rtError', halt',debug')
else
evalExp (Application (betaReduction aF' f e) aL t2) adfs