(***********************************************************************
This file was generated automatically by the Mathematica front end.
It contains Initialization cells from a Notebook file, which typically
will have the same name as this file except ending in ".nb" instead of
".m".

This file is intended to be loaded into the Mathematica kernel using
the package loading commands Get or Needs.  Doing so is equivalent to
using the Evaluate Initialiation Cells menu command in the front end.

DO NOT EDIT THIS FILE.  This entire file is regenerated automatically 
each time the parent Notebook file is saved in the Mathematica front end.
Any changes you make to this file will be overwritten.
***********************************************************************)

















exprMutationRANKS =
{
  PRexpr[_f,3,{PRexpr[_k,1,{}]}],
  PRexpr[_g,1,{}],
  PRexpr[_h,1,{}],
  PRexpr[_k,1,{}]
};

exprMutationRANKS::usage = 
"The ranks used by the mutation operator";



exprCrossoverRANKS = 
{
  PRexpr[_g,1,{}],
  PRexpr[_h,1,{}],
  PRexpr[_k,1,{}]
};

exprCrossoverRANKS::usage = 
"The ranks used by the crossover operator";



exprShrinkRANKS =
{
  PRexpr[_f,3,{PRexpr[_k,1,{}]}],
  PRexpr[_k,1,{}]
};

exprShrinkRANKS::usage = 
"The ranks used by the shrink operator";



exprDuplicationRANKS =
{
  PRexpr[_f,3,{PRexpr[_k,1,{}]}],
  PRexpr[_h,1,{}]
};

exprDuplicationRANKS::usage = 
"The ranks used by the duplication operator";



exprPermutationRANKS =
{ 
  PRexpr[_f,3,{PRexpr[_k,1,{}]}],
  PRexpr[_k,1,{}]
};

exprPermutationRANKS::usage = 
"The ranks used by the permutation operator";



exprEncapsulationRANKS =
{
  PRexpr[_k,1,{}]
};

exprEncapsulationRANKS::usage = 
"The ranks used by the encapsulation operator";



gpReproduction::usage =
"gpReproduction[population,fitnesses,newPopulation,options]\n
selects an individual from population according to the\n
problemspecific selection function and depending on the\n
individuals\[Bullet] fitnesses.\n
The selected individual is appended to newPopulation.";

gpReproduction[
  
  population_List,
  fitnesses_List,
  newPopulation_List,
  opts___

] := 

  Module[{selectedIndividual,
          selectedIndex,
          problemSpecificSelection =
           IndividualSelectionFunction /. {opts}
                                       /. Options[gpReproduction]},

    protoPrint2["Reproduction ..."];
    protoPrint[" "];
    protoPrint["***********************************"];

    selectedIndex = problemSpecificSelection[fitnesses];
    protoPrint["gpReproduction: Selected index: ",selectedIndex];

    selectedIndividual = population[[selectedIndex]];
    protoPrint["gpReproduction: selected individual: ",Short[selectedIndividual,2]];


    (* Update population history *)

    AppendTo[populationHistory, {REPRO, selectedIndex}];
  
  
    (* Return enhanced new population *)
    
    Append[newPopulation,selectedIndividual]

  ]; (* end module *)

Options[gpReproduction] := 
{
  IndividualSelectionFunction -> 
    rouletteWheelSelectionAttributesOnly
};



gpElitistReproduction[

  population_List,
  fitnesses_List,
  newPopulation_List,
  opts___
  
] :=

  Module[{selectedIndividual,
          selectedIndex
          },

    protoPrint2["Elitist Reproduction ..."];
    protoPrint[" "];
    protoPrint["***********************************"];
	
    selectedIndex = First[First[Position[fitnesses,Max[fitnesses]]]];
    protoPrint["elitistReproduction: Selected index: ",selectedIndex];

    selectedIndividual = population[[selectedIndex]];
    protoPrint["elitistReproduction: selected individual: ",Short[selectedIndividual,2]];

    (* Update population history *)

    AppendTo[populationHistory, {ELITIST, selectedIndex}];
    
    (* Return new population *)
    
    Append[newPopulation,selectedIndividual]
    
  ]; (* end module *)
  





gpMutation::usage =
"gpMutation[population,fitnesses,newPopulation,options]\n
selects an individual from population according to the\n
problemspecific selection function and depending on the\n
individuals\[Bullet] fitnesses.\n
The selected individual is mutated:\n
A subexpression is selected according to the specific\n
operator ranks, and this subexpression is replaced\n
by a newly generated expression.\n
The new individual is appended to newPopulation.";

gpMutation[
  
  population_List,
  fitnesses_List,
  newPopulation_List,
  opts___
  
] :=

  Module[{selectedIndividual,
          selectedIndex,
          mutatedIndividual = {},
          opInfo = {},
          problemSpecificSelection =
           IndividualSelectionFunction /. {opts}
                                       /. Options[gpMutation]
         },

    protoPrint2["Mutation ..."];
    protoPrint[" "];
    protoPrint["***********************************"];

    (* Select individual due to its fitness *)

    selectedIndex = problemSpecificSelection[fitnesses];
    protoPrint["gpMutation: Selected index: ",selectedIndex];

    selectedIndividual = population[[selectedIndex]];
    protoPrint["gpMutation: selected individual: ",Short[selectedIndividual,2]];
    
    {mutatedIndividual,opInfo} = 
      exprMutation[
        selectedIndividual,
        opts
      ];
    protoPrint["Mutated individual: ",Short[mutatedIndividual,2]];

    (* Update population history *)

    AppendTo[populationHistory, {MUTAT, selectedIndex, opInfo}]; 
  
  
    (* Return enhanced new population *)
    
    Append[newPopulation,mutatedIndividual]
    
  ]; (* end module *)
  
  

Options[gpMutation] := 
{
  GenerationPatterns -> exprGenerationPATTERNS,
  GenerationRanks -> exprGenerationRANKS,
  
  IndividualSelectionFunction -> 
    rouletteWheelSelectionAttributesOnly
};


exprMutation::constant =
 "The constant symbol `1` was selected, but will not be mutated.";
 
exprMutation::patternNotFound =
 "Pattern `1` is not present in expression `2`. No mutation performed.";
 

exprMutation[
  indivExpr_,
  opts___
] :=

Module[ {selectedPatterns,
         extractedExprs,
         selectionFunction =
           MutationSelectionFunction /. {opts} /. Options[exprMutation],
         theMutationRanks =
           MutationRanks /. {opts} /. Options[exprMutation],
         possiblePositions,
         selectedPosition,
         selectedSubPosition,
         selectedExpr,
         generatedSubExpr,
         newSubExpr,
         newExpr},
  
  (* Select an expression pattern for mutation ... *)
  
  selectedPatterns =
    patternSelection[theMutationRanks,opts];
  
  protoPrint[" "];
  protoPrint["-- exprMutation:"];
  protoPrint["-- -- indivExpr: ",indivExpr];
  protoPrint["-- -- selectedPatterns: ",selectedPatterns];
  
  (* Search for this pattern in the individual expression *)
  
  {extractedExprs,
   possiblePositions} =
    expressionExtraction[indivExpr,selectedPatterns];
    
  protoPrint["-- -- extractedExprs: ",extractedExprs];
  protoPrint["-- -- possiblePositions: ",possiblePositions];
  
  
  If[possiblePositions === {},
  
    theMessage[exprMutation::patternNotFound,
      selectedPatterns,Short[indivExpr]];
    Return[{indivExpr,{}}],
    
    (* Select one of the possible subexpressions ... *)
  
    selectedPosition = selectRandomElement[possiblePositions];

    protoPrint["-- -- possPos = ",possiblePositions];
    protoPrint["-- -- selPos  = ",selectedPosition];
  
    selectedExpr = Part[indivExpr,selectedPosition /. List -> Sequence];
    protoPrint["-- selExpr = ",selectedExpr];
  
    (* ... and mutate this subexpression ... *)
  
    If[Length[selectedExpr] > 0,
      newSubExpr = 
        doGenerateExprWithStart[Last[selectedPatterns],opts],
      theMessage[exprMutation::constant,selectedExpr];
      newSubExpr = selectedExpr
    ];
   
    protoPrint["-- -- newSub  = ",newSubExpr];
  
    (* Insert the mutated subexpression and return ... *)
  
    newExpr = 
      If[selectedPosition === {}, (* root *)
        newSubExpr,
        ReplacePart[indivExpr, newSubExpr, selectedPosition]
      ];

    {newExpr,{selectedPosition,selectedExpr,newSubExpr}}
  ]
  
  
] (* end module *)	

	

Options[exprMutation] := 
{
  MutationRanks -> exprMutationRANKS,
  MutationSelectionFunction -> rouletteWheelSelectionAttributesOnly
};






























gpCrossover::usage =
"gpCrossover[population,fitnesses,newPopulation,options]\n
selects two individuals from population according to the\n
problemspecific selection function and depending on the\n
individuals\[Bullet] fitnesses.\n
The selected individuals interchange subexpressions:\n
A subexpression is selected according to the specific\n
operator ranks, and this subexpression is searched for\n
in both expressions. If subexpression occurences \n
could be found an exchange of subexpressions is performed.\n
The new individuals are appended to newPopulation.";

gpCrossover[
  
  population_List,
  fitnesses_List,
  newPopulation_List,
  opts___

] := 

  Module[{indivOne, indivTwo,
          indexOne, indexTwo,
          newIndivOne, newIndivTwo,
          opInfo,
          problemSpecificSelection =
           IndividualSelectionFunction /. {opts}
                                       /. Options[gpCrossover]
         },
    
    protoPrint[" "];
    protoPrint2["gpCrossover:"];

    (* Select the two individuals due to their fitnesses *)

    indexOne = problemSpecificSelection[fitnesses];
    indexTwo = problemSpecificSelection[fitnesses];

    indivOne = population[[indexOne]];
    indivTwo = population[[indexTwo]];

    protoPrint["-- Selected indices: ",indexOne,", ",indexTwo];
    protoPrint["-- selected expressions: "];
    protoPrint["-- ** ",Short[indivOne,2]];
    protoPrint["-- ** ",Short[indivTwo,2]];
    
    {newIndivOne,newIndivTwo,opInfo} =
      exprCrossover[indivOne,indivTwo,opts];

    protoPrint["-- new individuals: "];
    protoPrint["-- ** ",Short[newIndivOne,2]];
    protoPrint["-- ** ",Short[newIndivTwo,2]];

    (* Update population history *)
    (* Return enhanced new population *)
    (* Append two individuals if possible ... *)
    
    protoPrint["popHistory: ",populationHistory];
    protoPrint["opInfo: ",opInfo];
    
    AppendTo[populationHistory, {CROSS, {indexOne,indexTwo},opInfo}];
    
    If[Length[newPopulation] < Length[population]-1,
      AppendTo[populationHistory, {CROSS, {indexTwo,indexOne},opInfo}];
      Join[newPopulation,{newIndivOne,newIndivTwo}],
      Append[newPopulation,newIndivOne]
    ]

  ]; (* end module: gpCrossover *)

Options[gpCrossover] := 
{
  IndividualSelectionFunction -> 
    rouletteWheelSelectionAttributesOnly
};


exprCrossover::patternNotFoundAtAll =
 "Expression `1` and `2` do not contain pattern `3`
  or the root symbol was selected. Crossover not performed.";
  

exprCrossover::patternNotFound =
 "Expression `1` or `2` does not contain pattern `3`.
  Crossover not performed.";
  

exprCrossover[
  exprOne_,
  exprTwo_,
  opts___
] :=
Module[{selectedPatterns,
        extractedExprsOne, extractedExprsTwo,
        possiblePositionsOne, possiblePositionsTwo,
        theCrossoverRanks =
          CrossoverRanks /. {opts} /. Options[exprCrossover],
        selectionFunction =
          CrossoverSelectionFunction /. {opts} /. Options[exprCrossover],
        positionOne,positionTwo,
        subExprOne = {},subExprTwo = {},
        newExprOne = {},newExprTwo = {}
       },
  
  protoPrint[" "];
  protoPrint["-- exprCrossover:"];
  protoPrint["-- -- exprOne: ",exprOne];
  protoPrint["-- -- exprTwo: ",exprTwo];
  
  (* Initialize the return expressions *)
  
  newExprOne = exprOne;
  newExprTwo = exprTwo;
  
  (* Select an expression pattern for crossover ... *)
  
  selectedPatterns =
    patternSelection[theCrossoverRanks,opts];

  protoPrint["-- -- selectedPatterns: ",selectedPatterns];
  
  {extractedExprsOne,
   possiblePositionsOne} =
    expressionExtraction[exprOne,selectedPatterns];
    
  {extractedExprsTwo,
   possiblePositionsTwo} =
    expressionExtraction[exprTwo,selectedPatterns];
    
  protoPrint["-- -- extractedExprsOne: ",extractedExprsOne];
  protoPrint["-- -- extractedExprsTwo: ",extractedExprsTwo];
  
  (* Search for this pattern in the individual expressions *)
  
  positionOne = selectRandomElement[possiblePositionsOne];
  positionTwo = selectRandomElement[possiblePositionsTwo];
  
  protoPrint["-- -- positionOne: ",positionOne];
  protoPrint["-- -- positionTwo: ",positionTwo];
  
  If[(positionOne === {}) || (positionTwo === {}),
  
    theMessage[exprCrossover::patternNotFound,
      Short[exprOne],Short[exprTwo],selectedPatterns];
    Return[
      {newExprOne,newExprTwo,
       {positionOne,positionTwo,{},{}}
      }
    ]
  ];
  
  (* Select one of the possible subexpressions, respectively ... *)
  (* ... and perform crossover ... *)
  
  
  subExprOne = Part[exprOne, positionOne /. List -> Sequence];
  subExprTwo = Part[exprTwo, positionTwo /. List -> Sequence];

  newExprOne = ReplacePart[exprOne, subExprTwo, positionOne];
  newExprTwo = ReplacePart[exprTwo, subExprOne, positionTwo];
  


  (* Return the two expressions after crossover *)
  
  {newExprOne,newExprTwo,{positionOne,positionTwo,
                          subExprOne,subExprTwo}
  }
  
]; (* end module *)


Options[exprCrossover] := 
{
  CrossoverRanks -> exprCrossoverRANKS,
  CrossoverSelectionFunction -> rouletteWheelSelectionAttributesOnly
};


















gpShrink::usage =
"gpShrink[population,fitnesses,newPopulation,options]\n
selects an individual from population according to the\n
problemspecific selection function and depending on the\n
individuals\[Bullet] fitnesses.\n
The selected individual is shrinked:\n
A subexpression is selected according to the specific\n
operator ranks, and a randomly selected argument is deleted.\n
The new individual is appended to newPopulation.";

gpShrink[
  
  population_List,
  fitnesses_List,
  newPopulation_List,
  opts___

] := 

  Module[{selectedIndividual,
          selectedIndex,
          shrinkedIndividual = {},
          opInfo = {},
          problemSpecificSelection =
           IndividualSelectionFunction /. {opts}
                                       /. Options[gpShrink]
         },
    
    protoPrint[" "];
    protoPrint2["Shrink:"];
    
    (* Select individual due to its fitness *)

    selectedIndex = problemSpecificSelection[fitnesses];
    selectedIndividual = population[[selectedIndex]];

    protoPrint["-- Selected index: ",selectedIndex];
    protoPrint["-- selected individual: ",Short[selectedIndividual,2]];
    
    {shrinkedIndividual,opInfo} = 
      exprShrink[
        selectedIndividual,
        opts
      ];
    protoPrint["-- Shrinked individual: ",Short[shrinkedIndividual,2]];

    (* Update population history *)

    AppendTo[populationHistory, {SHRINK, selectedIndex, opInfo}]; 
  
  
    (* Return enhanced new population *)
    
    Append[newPopulation,shrinkedIndividual]
    
  ]; (* end module: gpShrink *)

Options[gpShrink] := 
{
  IndividualSelectionFunction -> 
    rouletteWheelSelectionAttributesOnly
};


exprShrink::patternNotFound =
 "Pattern `1` is not present in expression `2`. No shrink performed.";
 
exprShrink::constant = 
 "Expression `1` is a constant. No shrink performed.";
 
exprShrink::oneArgument =
 "Expression `1` has only one argument. No shrink performed.";
 

exprShrink[
  indivExpr_,
  opts___
] :=

Module[ {selectedPatterns, extractedExprs,
         selectionFunction =
           ShrinkSelectionFunction /. {opts} /. Options[exprShrink],
         theShrinkRanks =
           ShrinkRanks /. {opts} /. Options[exprShrink],
         possiblePositions,
         selectedPosition,
         selectedExpr,
         newSubExpr,
         newExpr,
         numberOfArguments},

  protoPrint[" "];
  protoPrint["-- exprShrink:"];
  protoPrint["-- -- indivExpr: ",indivExpr];
  
  (* Select an expression pattern for shrinkage ... *)
  
  selectedPatterns =
    patternSelection[theShrinkRanks,opts];
  
  protoPrint["-- -- selectedPatterns: ",selectedPatterns];
  
  (* Search for this pattern in the individual expression *)
  
  {extractedExprs,
   possiblePositions} =
    expressionExtraction[indivExpr,selectedPatterns];
    
  protoPrint["-- -- extractedExprs: ",extractedExprs];
  protoPrint["-- -- possiblePositions: ",possiblePositions];
  
  If[possiblePositions === {},
  
    theMessage[exprShrink::patternNotFound,
      selectedPatterns,Short[indivExpr]];
    Return[{indivExpr,{}}],
    
    (* Select one of the possible subexpressions ... *)
  
    selectedPosition = selectRandomElement[possiblePositions];

    protoPrint["-- -- possPos = ",possiblePositions];
    protoPrint["-- -- selPos  = ",selectedPosition];
  
    selectedExpr = Part[indivExpr,selectedPosition /. List -> Sequence];
    numberOfArguments = Length[selectedExpr];
    
    protoPrint["-- -- selExpr = ",selectedExpr];
    protoPrint["-- -- numberOfArguments: ",numberOfArguments];

    (* ... and shrink this subexpression ... *)
  
    If[Length[selectedExpr] > 0,
      If[Length[selectedExpr] > 1,
        newSubExpr = 
          Delete[selectedExpr,Random[Integer,{1,numberOfArguments}]],
        theMessage[exprShrink::oneArgument,selectedExpr];
        newSubExpr = selectedExpr
      ],
      theMessage[exprShrink::constant,selectedExpr];
      newSubExpr = selectedExpr
    ];
   
    protoPrint["-- -- newSub  = ",newSubExpr];
  
    (* Insert the shrinked subexpression and return ... *)
  
    newExpr = 
      If[selectedPosition === {}, (* root *)
        newSubExpr,
        ReplacePart[indivExpr, newSubExpr, selectedPosition]
    ];

    {newExpr,{selectedPosition,selectedExpr,newSubExpr}}
  ]
  
] (* end module *)	

	

Options[exprShrink] := 
{
  ShrinkRanks -> exprShrinkRANKS,
  ShrinkSelectionFunction -> rouletteWheelSelectionAttributesOnly
};



















gpDuplication::usage =
"gpDuplication[population,fitnesses,newPopulation,options]\n
selects an individual from population according to the\n
problemspecific selection function and depending on the\n
individuals\[Bullet] fitnesses.\n
Duplication is performed on the selected individual:\n
A subexpression is selected according to the specific\n
operator ranks, and a randomly selected argument is duplicated.\n
The new individual is appended to newPopulation.";

gpDuplication[
  
  population_List,
  fitnesses_List,
  newPopulation_List,
  opts___
  
] :=

  Module[{selectedIndividual,
          selectedIndex,
          duplicatedIndividual = {},
          opInfo = {},
          problemSpecificSelection =
           IndividualSelectionFunction /. {opts}
                                       /. Options[gpDuplication]
         },

    protoPrint2["Duplication ..."];
    protoPrint[" "];
    protoPrint["***********************************"];

    (* Select individual due to its fitness *)

    selectedIndex = problemSpecificSelection[fitnesses];
    protoPrint["gpDuplication: Selected index: ",selectedIndex];

    selectedIndividual = population[[selectedIndex]];
    protoPrint["gpDuplication: selected individual: ",Short[selectedIndividual,2]];
    
    {duplicatedIndividual,opInfo} = 
      exprDuplication[
        selectedIndividual,
        opts
      ];
    protoPrint["Duplicated individual: ",Short[duplicatedIndividual,2]];

    (* Update population history *)

    AppendTo[populationHistory, {DUPL, selectedIndex, opInfo}]; 
  
  
    (* Return enhanced new population *)
    
    Append[newPopulation,duplicatedIndividual]
    
  ]; (* end module *)
  
  

Options[gpDuplication] := 
{
  IndividualSelectionFunction -> 
    rouletteWheelSelectionAttributesOnly
};


exprDuplication::patternNotFound =
 "Pattern `1` is not present in expression `2`. No duplication performed.";
 

exprDuplication[
  indivExpr_,
  opts___
] :=

Module[ {selectedPatterns, extractedExprs, posIndex,
         selectionFunction =
           DuplicationSelectionFunction /. {opts} /. Options[exprDuplication],
         theDuplicationRanks =
           DuplicationRanks /. {opts} /. Options[exprDuplication],
         possiblePositions,
         selectedPosition,
         selectedExpr,
         newSubExpr,
         newExpr,
         numberOfArguments},

  protoPrint[" "];
  protoPrint["-- exprDuplication:"];
  protoPrint["-- -- indivExpr: ",indivExpr];
  
  (* Select an expression pattern for duplication ... *)
  
  selectedPatterns =
    patternSelection[theDuplicationRanks,opts];
  
  protoPrint["-- -- selectedPatterns: ",selectedPatterns];
  
  (* Search for this pattern in the individual expression *)
  
  {extractedExprs,
   possiblePositions} =
    expressionExtraction[indivExpr,selectedPatterns];
    
  protoPrint["-- -- extractedExprs: ",extractedExprs];
  protoPrint["-- -- possiblePositions: ",possiblePositions];
  
  If[possiblePositions === {},
  
    theMessage[exprDuplication::patternNotFound,
      selectedPatterns,Short[indivExpr]];
    Return[{indivExpr,{}}],
    
    (* Select one of the possible subexpressions ... *)
  
    selectedPosition = selectRandomElement[possiblePositions];

    protoPrint["-- -- possPos = ",possiblePositions];
    protoPrint["-- -- selPos  = ",selectedPosition];
  
    selectedExpr = Part[indivExpr,selectedPosition /. List -> Sequence];
    numberOfArguments = Length[selectedExpr];
    
    protoPrint["-- -- selExpr = ",selectedExpr];
    protoPrint["-- -- numberOfArguments: ",numberOfArguments];

    (* ... and duplicate an argument of this subexpression ... *)
  
    If[Length[selectedExpr] > 0,
      posIndex = Random[Integer,{1,numberOfArguments}];
      newSubExpr = 
        Insert[selectedExpr,selectedExpr[[posIndex]],posIndex],
        
      theMessage[exprDuplication::constant,selectedExpr];
      newSubExpr = selectedExpr
    ];
   
    protoPrint["-- -- newSub  = ",newSubExpr];
  
    (* Insert the duplicated subexpression and return ... *)
  
    newExpr = 
      If[selectedPosition === {}, (* root *)
        newSubExpr,
        ReplacePart[indivExpr, newSubExpr, selectedPosition]
    ];

    {newExpr,{selectedPosition,selectedExpr,newSubExpr}}
  ]
  
] (* end module *)	

	

Options[exprDuplication] := 
{
  DuplicationRanks -> exprDuplicationRANKS,
  DuplicationSelectionFunction -> rouletteWheelSelectionAttributesOnly
};


















gpPermutation::usage =
"gpPermutation[population,fitnesses,newPopulation,options]\n
selects an individual from population according to the\n
problemspecific selection function and depending on the\n
individuals\[Bullet] fitnesses.\n
Permutation is performed on the selected individual:\n
A subexpression is selected according to the specific\n
operator ranks, and its arguments are permuted depending\n
on the permutation function defined as an option.\n
The new individual is appended to newPopulation.";

gpPermutation[
  
  population_List,
  fitnesses_List,
  newPopulation_List,
  opts___

] := 

  Module[{selectedIndividual,
          selectedIndex,
          permutedIndividual = {},
          opInfo = {},
          problemSpecificSelection =
           IndividualSelectionFunction /. {opts}
                                       /. Options[gpPermutation]
         },

    protoPrint2["Argument permutation ..."];
    protoPrint[" "];
    protoPrint["***********************************"];
    protoPrint[" "];
    
    (* Select individual due to its fitness *)

    selectedIndex = problemSpecificSelection[fitnesses];
    protoPrint["gpPermutation: Selected index: ",selectedIndex];

    selectedIndividual = population[[selectedIndex]];
    protoPrint["gpPermutation: selected individual: ",Short[selectedIndividual,2]];
    
    {permutedIndividual,opInfo} = 
      exprPermutation[
        selectedIndividual,
        opts
      ];
    protoPrint["Permuted individual: ",Short[permutedIndividual,2]];

    (* Update population history *)

    AppendTo[populationHistory, {PERM, selectedIndex, opInfo}]; 
  
  
    (* Return enhanced new population *)
    
    Append[newPopulation,permutedIndividual]
        
  ]; (* end module *)

Options[gpPermutation] := 
{
  IndividualSelectionFunction -> 
    rouletteWheelSelectionAttributesOnly
};


exprPermutation::patternNotFound =
 "Pattern `1` is not present in expression `2`. No shrink performed.";
 

exprPermutation[
  indivExpr_,
  opts___
] :=

Module[ {selectedPatterns, extractedExprs,
         selectionFunction =
           PermutationSelectionFunction /. {opts} /. Options[exprPermutation],
         thePermutationRanks =
           PermutationRanks /. {opts} /. Options[exprPermutation],
         thePermutationFunction =
           PermutationFunction /. {opts} /. Options[exprPermutation],
         possiblePositions,
         selectedPosition,
         selectedExpr,
         newSubExpr,
         newExpr,
         numberOfArguments},

  protoPrint[" "];
  protoPrint["-- exprPermutation:"];
  protoPrint["-- -- thePermutationFunction: ",thePermutationFunction];
  protoPrint["-- -- indivExpr: ",indivExpr];
  
  (* Select an expression pattern for permutation ... *)
  
  selectedPatterns =
    patternSelection[thePermutationRanks,opts];
  
  protoPrint["-- -- selectedPatterns: ",selectedPatterns];
  
  (* Search for this pattern in the individual expression *)
  
  {extractedExprs,
   possiblePositions} =
    expressionExtraction[indivExpr,selectedPatterns];
    
  protoPrint["-- -- extractedExprs: ",extractedExprs];
  protoPrint["-- -- possiblePositions: ",possiblePositions];
  
  If[possiblePositions === {},
  
    theMessage[exprPermutation::patternNotFound,
      selectedPatterns,Short[indivExpr]];
    Return[{indivExpr,{}}],
    
    (* Select one of the possible subexpressions ... *)
  
    selectedPosition = selectRandomElement[possiblePositions];

    protoPrint["-- -- possPos = ",possiblePositions];
    protoPrint["-- -- selPos  = ",selectedPosition];
  
    selectedExpr = Part[indivExpr,selectedPosition /. List -> Sequence];
    numberOfArguments = Length[selectedExpr];
    
    protoPrint["-- -- selExpr = ",selectedExpr];
    protoPrint["-- -- numberOfArguments: ",numberOfArguments];

    (* ... and permute the arguments of this subexpression ... *)
  
    If[Length[selectedExpr] > 0,
      newSubExpr = 
        thePermutationFunction[selectedExpr],
      theMessage[exprPermutation::constant,selectedExpr];
      newSubExpr = selectedExpr
    ];
   
    protoPrint["-- -- newSub  = ",newSubExpr];
  
    (* Insert the permuted subexpression and return ... *)
  
    newExpr = 
      If[selectedPosition === {}, (* root *)
        newSubExpr,
        ReplacePart[indivExpr, newSubExpr, selectedPosition]
    ];

    {newExpr, {selectedPosition, selectedExpr, newSubExpr,
               thePermutationFunction}
    }
  ]
  
] (* end module *)	

	

Options[exprPermutation] := 
{
  
  PermutationFunction -> 
    selectRandomElement[
      {Reverse,RotateLeft,RotateRight}
    ],
    
  PermutationRanks -> exprShrinkRANKS,
  PermutationSelectionFunction -> rouletteWheelSelectionAttributesOnly
  
};


















encapsPatternList = {}; (* pool for encapsulated patterns *)

encapsRulesList = {}; (* rules pool for encapsulated expressions *)

gpEncapsulation::usage =
"gpEncapsulation[population,fitnesses,newPopulation,options]\n
selects an individual from population according to the\n
problemspecific selection function and depending on the\n
individuals\[Bullet] fitnesses.\n
Encapsulation is performed on the selected individual:\n
A level is selected randomly, and all expressions\n
with a level higher than the selected level\n
are considered as formal parameters of a newly created\n
function. The body of this function keeps all expressions\n
with a smaller than the selected level.\n
The new individual is appended to newPopulation.";

gpEncapsulation[
  
  population_List,
  fitnesses_List,
  newPopulation_List,
  opts___
  
] :=

  Module[{selectedIndividual,
          selectedIndex,
          encapsulatedIndividual = {},
          encapsRule = {},
          encapsPattern = {},
          opInfo = {},
          problemSpecificSelection =
           IndividualSelectionFunction /. {opts}
                                       /. Options[gpEncapsulation]
         },

    protoPrint2["Encapsulation ..."];
    protoPrint[" "];
    protoPrint["***********************************"];

    (* Select individual due to its fitness *)

    selectedIndex = problemSpecificSelection[fitnesses];
    protoPrint["gpEncapsulation: Selected index: ",selectedIndex];

    selectedIndividual = population[[selectedIndex]];
    protoPrint["gpEncapsulation: selected individual: ",Short[selectedIndividual,2]];
    
    {{encapsulatedIndividual,encapsPattern,encapsRule},
     opInfo
    } = 
      exprEncapsulation[
        selectedIndividual,
        opts
      ];
      
    protoPrint["Encapsulated individual: ",Short[encapsulatedIndividual,2]];
    protoPrint["-- encapsPattern: ",encapsPattern];
    protoPrint["-- encapsRule: ",encapsRule];
    
    (* Update population history *)

    AppendTo[populationHistory, {ENCAPS, selectedIndex, opInfo}]; 
    
    (* Update excapsulation list *)
    
    If[encapsPattern =!= {},
      AppendTo[encapsPatternList,encapsPattern]
    ];
    If[encapsRule =!= {},
      AppendTo[encapsRulesList,encapsRule]
    ];
    
    (* Return enhanced new population *)
    
    Append[newPopulation,encapsulatedIndividual]
    
  ]; (* end module *)
  
  

Options[gpEncapsulation] := 
{
  IndividualSelectionFunction -> 
    rouletteWheelSelectionAttributesOnly
};


exprEncapsulation::constant =
 "The constant symbol `1` was selected, but will not be encapsulated.";
 
exprEncapsulation::patternNotFound =
 "Pattern `1` is not present in expression `2`. No encapsulation performed.";
 

exprEncapsulation[
  indivExpr_,
  opts___
] :=

Module[ {selectedPatterns, extractedExprs,
         selectionFunction =
           EncapsulationSelectionFunction /. {opts} /. Options[exprEncapsulation],
         theEncapsulationRanks =
           EncapsulationRanks /. {opts} /. Options[exprEncapsulation],
         possiblePositions,
         selectedPosition,
         selectedLevel,
         selectedExpr,
         newSubExpr,
         newExpr,
         encapsPattern = {}, encapsRule = {}, vars = {}, theDepth},
  
  (* Select an expression pattern for encapsulation ... *)
  
  selectedPatterns =
    patternSelection[theEncapsulationRanks,opts];
  
  protoPrint[" "];
  protoPrint["-- exprEncapsulation:"];
  protoPrint["-- -- indivExpr: ",indivExpr];
  protoPrint["-- -- selectedPatterns: ",selectedPatterns];
  
  (* Search for this pattern in the individual expression *)
  
  {extractedExprs,
   possiblePositions} =
    expressionExtraction[indivExpr,selectedPatterns];
    
  protoPrint["-- -- extractedExprs: ",extractedExprs];
  protoPrint["-- -- possiblePositions: ",possiblePositions];
  
  If[possiblePositions === {},
    
    protoPrint["Pattern ",selectedPattern," not found in ",indivExpr];
    
    theMessage[exprEncapsulation::patternNotFound,
      selectedPatterns,Short[indivExpr]];
    newSubExpr = indivExpr,
    
    (* Select one of the possible subexpressions ... *)
  
    selectedPosition = selectRandomElement[possiblePositions];

    protoPrint["-- -- possPos = ",possiblePositions];
    protoPrint["-- -- selPos  = ",selectedPosition];
  
    selectedExpr = Part[indivExpr,selectedPosition /. List -> Sequence];
    protoPrint["-- selExpr = ",selectedExpr];
  
    (* ... and encapsulate this subexpression ... *)
  
    If[Length[selectedExpr] > 0,
    
      (* Select a level for encapsulation *)
      
      If[(theDepth = Depth[selectedExpr]) < 2, theDepth = 2];
      
      selectedLevel = Random[Integer,{2,theDepth}];
      
      protoPrint["-- -- selLevel  = ",selectedLevel];
      
      {encapsPattern,encapsRule,vars,newSubExpr} = 
        patternExtraction[selectedExpr,selectedLevel]
    ];
  ];
  
  protoPrint["-- -- newSub  = ",newSubExpr];
  
  (* Insert the encapsulated subexpression and return ... *)
    
  newExpr = 
    If[selectedPosition === {} (* root *) ||
       possiblePositions === {},
      newSubExpr,
      ReplacePart[indivExpr, newSubExpr, selectedPosition]
    ];
    
    {{newExpr,encapsPattern,encapsRule},
     {selectedPosition, selectedExpr, newSubExpr,selectedLevel}} 
    
] (* end module: exprEncapsulation *)	

	

Options[exprEncapsulation] :=
{
  EncapsulationRanks -> exprEncapsulationRANKS,
  EncapsulationSelectionFunction -> rouletteWheelSelectionAttributesOnly
};




createVariables[sym_String,howMany_Integer] :=
  Map[ToExpression[StringJoin[sym,ToString[#]]]&,Range[howMany]]







patternExtraction[expr_, level_] := {expr,{},{},{}};

patternExtraction[expr_, level_/; level > 0] :=
Module[{levelSpec,
        casesList,
        headsList,
        posList,
        patternList,
        combinedList,
        variablesList,
        subExprList},

  doReplacePart[e_,{newExpr_,pos_}] :=
    ReplacePart[e,newExpr,pos];
  
  createVariables[sym_String,howMany_Integer] :=
    Map[ToExpression[StringJoin[sym,ToString[#]]]&,Range[howMany]];
    
  levelSpec = {level,level};
  casesList = Cases[expr,_,levelSpec];
  headsList = Map[Head[#]&, casesList];

  posList = Map[First[Position[expr,#,levelSpec]]&, casesList];

  patternList = 
    MapThread[
      If[# === Symbol, Pattern[#2,Blank[]],Pattern[#2,Blank[#1]]]&,
      {headsList,variablesList = createVariables["x",Length[headsList]]}];

  combinedList = Transpose[{patternList,posList}];
  
  subExprList = Map[Part[expr,Apply[Sequence,#]]&,posList];
  
  (**
  Print["casesList: ",casesList];
  Print["headsList: ",headsList];
  Print["posList: ",posList];
  Print["patternList: ",patternList];
  Print["combinedList: ",combinedList];
  Print["headsList: ",headsList];
  Print["variablesList: ",variablesList];
  Print["subExprList: ",subExprList];
  **)
  
  fctHead = Unique[Head[expr]];
  
  { 
    fctPattern = Fold[doReplacePart,expr,combinedList],
    RepRule[
      Apply[fctHead,patternList],
      Fold[doReplacePart,expr,Transpose[{variablesList,posList}]]
    ] /. {RepRule -> RuleDelayed},
    vars = Transpose[{variablesList,subExprList}],
    Apply[fctHead,Map[#[[2]]&,vars]]
  }
];

















































































































































adjustgpOperatorRanks::print =
 "`1` `2`";

adjustgpOperatorRanks[opts___] :=

Module[{currentFitnesses = {},
        previousFitnesses = {},
        operatorApplicationList = {},
        operatorAdjustmentList = {},
        theIndex
       },

  (* Go through the GA operator history list of the current generation *)
  (* For each entry get the individual(s) used by an operator *)
  (* Get the last and current fitness value(s) of the individual(s) ... *)
  (* ... and decide what to do with the according operator's rank *)
  
  currentFitnesses = populationFitnesses;
  previousFitnesses = previousPopFitnesses;
    
  
  operatorApplicationList = Map[Take[#,2]&,populationHistory];
  
  
  operatorAdjustmentList =
    MapIndexed[
      {First[#1],
       previousFitnesses[[
         If[VectorQ[(theIndex = Part[#1,2])] === True,
           First[theIndex],
           theIndex
         ]
       ]],
       currentFitnesses[[First[#2]]]}&,
      operatorApplicationList
    ];
  
    
  (* Set the global GA operator ranks to the new values *)
  
  gpOperatorRanks =
    Sort[adjustRanks[operatorAdjustmentList,opts]];
  
    
  (* Append the new ranks to the global ranks list *)
  (* ... and produce graphics output*)
  
  AppendTo[gpOperatorRanksList,gpOperatorRanks];
  
  gaRanksChart3D[gpOperatorRanksList];
  
  gpOperatorRanks
  
]; (* end module *)


adjustRanks[opAdjustmentList_List,opts___] :=

Module[{opFitList = {},
        deltaRanksList = {}},

  (* Special treatment of the crossover operator: *)
  (* Only keep the advantageous effect of crossover *)
  
  opFitList =
    opAdjustmentList /. {{x___,{CROSS,y1_,y2_},{CROSS,y3_,y4_},z___} :>
      {x,{CROSS,y1,y2},z} /; (y2-y1) > (y4-y3)};
  
  opFitList =
    opFitList /. {{x___,{CROSS,y1_,y2_},{CROSS,y3_,y4_},z___} :>
      {x,{CROSS,y3,y4},z} /; (y2-y1) <= (y4-y3)};
  
  
  (* Adjust each operator's rank ... *)
  
  deltaRanksList =
    opFitList /. {op_,oldFit_,newFit_} :> {op,N[newFit/oldFit]};
  
  
  (* Collect all success values for each operator *)
  
  deltaRanksList =
    deltaRanksList //.
      {x___,{op_,x1_},y___,{op_,x2_},z___} :> 
      {x,{op,Flatten[{x1,x2}]},y,z};
  
  
  (* Wrap all numbers into lists ... *)

  deltaRanksList =
    Map[
      {#[[1]],Flatten[{#[[2]]}]}&,
      deltaRanksList
    ];
    
  Print["deltaRanksList 2: ",deltaRanksList];
  
  (* Replace each list of numbers by their mean value *)

  deltaRanksList =
    Map[
      {#[[1]],N[Mean[#[[2]]]]}&,
      deltaRanksList
    ];
    
  
  (* Combine the rank scalings with the global GA operator ranks *)
  
  deltaRanksList =
  Join[deltaRanksList,gpOperatorRanks]
     //. {x___,{op_,x1_},y___,{op_,x2_},z___} :> 
         {x,{op,N[x1 x2]},y,z};
     
  Print["deltaRanksList: ",deltaRanksList];
      
  (* Normalize the ranks *)
  
  maximumRank = MaxOperatorRank /. {opts} /. Options[adjustRanks];
  minimumRank = MinOperatorRank /. {opts} /. Options[adjustRanks];
  
  deltaRanksList =
  deltaRanksList /. {x_/;NumberQ[x] && x > maximumRank :> maximumRank,
                     x_/;NumberQ[x] && x < minimumRank :> minimumRank
                    };
  
  Print["normalized deltaRanksList: ",deltaRanksList];
  
  deltaRanksList
  
]; (* end module *)


Options[adjustRanks] =
{
  MaxOperatorRank -> 10,
  MinOperatorRank -> 0.1
};

extractExpr[searchExpr_,searchPattern_] :=

Module[{thePosition = {},
        theExpr = {}},

  thePosition =
    Position[searchExpr,searchPattern];
    
  theExpr = Part[searchExpr,thePosition /. List -> Sequence];
  
  {theExpr,thePosition}
];

































Needs["Graphics`MultipleListPlot`"];

gaRanksChart3D[gaRanks_List] :=
Module[{l,
        data},
  
  (* Extract ranks ... *)
  
  data = 
    Map[
      Map[Last[#]&,#]&,
      gaRanks
    ];
  
  
  If[(l = Length[data]) > 1,
    
    i=0;
    combinedGraphic =
    Show[
    MapThread[
      Show[#1,PlotLabel -> #2,DisplayFunction -> Identity]&,
      {MapThread[
        ListPlot[{##},
          PlotJoined -> True,
          PlotStyle -> {Hue[i = i + 0.1]},
          DisplayFunction -> Identity
        ]&,
        data
      ],
      Map[First[#]&,gpOperatorRanks]}
    ],DisplayFunction -> Identity];
    
    i=0;
    Show[
      GraphicsArray[Partition[
        MapThread[
          Show[#1,PlotLabel -> #2,DisplayFunction -> Identity]&,
          {Append[
           MapThread[
            ListPlot[{##},
              PlotJoined -> True,
              PlotStyle -> {Thickness[0.014],Hue[i = i + 0.1]},
              DisplayFunction -> Identity
            ]&,
            data
           ],
           combinedGraphic
          ],
          Append[Map[First[#]&,gpOperatorRanks],"GP Operators"]}
        ],
        2
      ]],
      DisplayFunction -> $DisplayFunction,
      PlotLabel -> FontForm["GP Operator Ranks",{"Times-Bold",12}],
      Background -> GrayLevel[0.8]
    ],
    
    
    
    
    BarChart[First[data],
      BarEdges -> True,
      BarLabels -> 
        Append[Table[" ",{Length[First[data]]-1}],
        Length[First[data]]],
      BarSpacing -> Automatic,
      BarStyle -> (GrayLevel[0.0]&),
      BarOrientation -> Vertical,
      DefaultFont -> {"Helvetica",12},
      PlotLabel -> "GP Operator Ranks",
      PlotRange -> All
    ]
  ];
  
  
]; (* end module *)











protoPrint[args___] :=
Module[{},
  If[(doPrint /. Options[protoPrint]) === True,
    Print[args]
  ];
];

Options[protoPrint] :=
{
  doPrint -> False
};

protoPrint2[args___] :=
Module[{},
  If[(doPrint /. Options[protoPrint]) === True,
    Print[args]
  ];
];

Options[protoPrint2] :=
{
  doPrint -> False
};






rouletteWheelSelection[rules_List,
                       attributes_List] :=

Module[ {members, totalsum, partsum, index, randpos},

	members		=	Length[rules];
	totalsum	= 	Apply[Plus,attributes];
	partsum  	= 	attributes[[1]];
	index    	= 	1;
	
	randpos  	=	Random[Real,totalsum];
	
	While[partsum < randpos && index < members,
	
		index = index + 1;
		partsum = partsum + attributes[[index]];
		
	]; (* end while *)
	
	Print["Selected rule: ",rules[[index]]];
	index

] (* end module *)



rouletteWheelSelectionAttributesOnly[attributes_List] :=

Module[ {members, totalsum, partsum, index, randpos},

	members		=	Length[attributes];
	totalsum	= 	Apply[Plus,attributes];
	partsum  	= 	attributes[[1]];
	index    	= 	1;
	
	randpos  	=	Random[Real,{0,N[totalsum]}];
	
	While[partsum < randpos && index < members,
	
		index = index + 1;
		partsum = partsum + attributes[[index]];
		
	]; (* end while *)
	
	(** Print["Selected index: ",index]; **)
	index

] (* end module *)



rankBasedSelection[ranks_Integer] :=

Module[ {totalsum, partsum, partsumTable, index, randpos},

	totalsum	= 	Sum[i,{i,1,ranks}];
        Print["totalsum: ",totalsum];
	partsumTable 	= 	Table[i,{i,ranks,1,-1}];
        Print["partsumTable: ",partsumTable];
	partsum		=	partsumTable[[1]];
	index    	= 	1;
	
	randpos  	=	Random[Integer,{1,totalsum}];
	
	While[partsum < randpos && index < ranks,
	
		index = index + 1;
		partsum = partsum + partsumTable[[index]];
		
	]; (* end while *)
	
	(** Print["Selected index: ",index]; **)
	index

]; (* end module *)



rankBasedSelectionExp[ranks_Integer] :=

Module[ {totalsum, partsum, partsumTable, index, randpos},

	partsumTable 	= 	Table[N[Exp[-i]],{i,0,ranks-1,1}];
        Print["partsumTable: ",partsumTable];
	totalsum	= 	Sum[partsumTable[[i]],{i,1,ranks}];
        Print["totalsum: ",totalsum];

	partsum		=	partsumTable[[1]];
	index    	= 	1;
	
	randpos  	=	Random[Real,{0,totalsum}];
	Print["randpos: ",randpos];

	While[partsum < randpos && index < ranks,
	
		index = index + 1;
		partsum = partsum + partsumTable[[index]];
		
	]; (* end while *)
	
	(** Print["Selected index: ",index]; **)
	index

]; (* end module *)














patternSelection[{},opts___] = {};

patternSelection[patternsAndRanks_List,opts___] :=

Module[{
        selectedIndex, 
        selectedPattern,
        selectionFunction =
           PatternSelectionFunction /. {opts} 
                                    /. Options[patternSelection]},
  
  selectedIndex = 
    selectionFunction[Map[#[[2]]&,patternsAndRanks]];
    
  selectedPattern =
    First[Part[patternsAndRanks,selectedIndex]];
    
  {selectedPattern,
   patternSelection[Part[patternsAndRanks,selectedIndex][[3]]]}
   // Flatten
];

Options[patternSelection] :=
{
  PatternSelectionFunction -> rouletteWheelSelectionAttributesOnly
}













expressionExtraction[expr_,patternList_List] :=

Module[{},
  
  firstPattern = Last[patternList];
  thePatterns  = Drop[Reverse[patternList],1];
  
  Fold[
    {
      Cases[
        expr,
        Pattern[x,#2] /;
          MemberQ[x,Apply[Alternatives,#1[[1]]],Infinity],
        Infinity
      ],
      extractPositions[
        #1[[2]],
        Position[
          expr,
          Pattern[x,#2] /;
            MemberQ[x,Apply[Alternatives,#1[[1]]],Infinity],
          Infinity
        ]
      ]
    }&,
    {Cases[expr,firstPattern,Infinity],
     Position[expr,firstPattern,Infinity]},
    thePatterns
  ]
];























extractPositions[posInner_List,posOuter_List] :=

Module[{},
  
  Flatten[
    Map[
      Cases[
        posInner,
        x_List /; # === Take[x,Length[#]]
      ]&,
      posOuter
    ],
    1
  ]
];







































