{---------------------------------------------------------------
 --
 -- Auxil.hs : contains supporting function defination for the system.
 -- [email protected]	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 NonStdTrace

-- 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)
    }