Expression Modification

C. Jacob

January 1995

(copyright)

GP Operators

?gp*

Expression template ranks

The hierarchical descriptions of ranked expressions are used by the genetic operators in order to find expressions for modification.

Mutation

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";

Crossover

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

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

Shrink

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

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

Duplication

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

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

Permutation

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

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

Encapsulation

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

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

Reproduction

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• 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 *)

Mutation

Functions

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• 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
};

theExpressions1 = exprGeneration[2,_f]

Map[
  exprMutation[
    #,
    MutationSelectionFunction -> rouletteWheelSelectionAttributesOnly,
    MutationRanks -> exprMutationRANKS
  ]&,
  theExpressions1
]

Examples ...

myExpr =
 f[
   g[a],
   h[b],
   f[1,k[e],3],
   k[1,2,h[c]],
   f[d,k[h[b],2,3]],
   f[h[a],b,1]
 ]

First evaluate Expression Templates in the Examples section ...

exprMutation[myExpr]

Crossover

Functions

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• 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
};

Examples ...

myExpr =
 f[
   g[a],
   h[b],
   f[1,k[e],3],
   k[1,2,h[c]],
   f[d,k[h[b],2,3]],
   f[h[a],b,1]
 ]

exprCrossover[myExpr,myExpr]

Shrink

Functions

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• 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
};

Examples ...

myExpr =
 f[
   g[a],
   h[b],
   f[1,k[e],3],
   k[1,2,h[c]],
   f[d,k[h[b],2,3]],
   f[h[a],b,1]
 ]

exprShrink[myExpr]

Duplication

Functions

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• 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
};

Examples ...

myExpr =
 f[
   g[a],
   h[b],
   f[1,k[e],3],
   k[1,2,h[c]],
   f[d,k[h[b],2,3]],
   f[h[a],b,1]
 ]

exprDuplication[myExpr]

Permutation

Functions

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• 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
  
};

Examples ...

myExpr =
 f[
   g[a],
   h[b],
   f[1,k[e],3],
   k[1,2,h[c]],
   f[d,k[h[b],2,3]],
   f[h[a],b,1]
 ]

exprPermutation[myExpr]

Encapsulation (generalized version)

Functions

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• 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
};

How to extract patterns that can be appended to the patterns list.
This function should return the following components:

	{	
		functional definition of the extracted pattern,
		extracted pattern,
		created variables,
		values of the created variables
	}

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

FullForm[createVariables["x",4]]

ClearAll[patternExtraction]

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]]
  }
];

Examples: Pattern extraction

myExpr = f[a,g[b,h[d]],i[e]]

Level 0:

{fctPattern,fctRule,vars,newExpr} = patternExtraction[myExpr,0]

Level 1:

{fctPattern,fctRule,vars,newExpr} = patternExtraction[myExpr,1]

Level 2:

{fctPattern,fctRule,vars,newExpr} = patternExtraction[myExpr,2]

Level 3:

{fctPattern,fctRule,vars,newExpr} = patternExtraction[myExpr,3]

Level 4:

{fctPattern,fctRule,vars,newExpr} = patternExtraction[myExpr,4]

Level  5:

{fctPattern,fctRule,vars,newExpr} = patternExtraction[myExpr,5]

Examples: Encapsulation

myExpr =
 f[
   g[a],
   h[b],
   f[1,k[e],3],
   k[1,2,h[c]],
   f[d,k[h[b],2,3]],
   f[h[a],b,1]
 ]

exprEncapsulation[myExpr]

populationHistory = {};
encapsPatternList = {};
encapsRulesList = {};

problemSpecificSelection = rouletteWheelSelectionAttributesOnly;

newPopulation = gpEncapsulation[{myExpr},{1},{}]

populationHistory

encapsPatternList

encapsRulesList

newPopulation

newPopulation /. encapsRulesList

Encapsulation (old version!)

Do not use this version of encapsulation any more!
There is a more general version defined above.

Functions

encapsulationList = {}; (* pool for encapsulated expressions *)
                        (* and associated symbols            *)

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

  Module[{selectedIndividual,
          selectedIndex,
          encapsulatedIndividual = {},
          encapsDefinition = {},
          opInfo = {}
         },

    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,encapsDefinition},opInfo} = 
      exprEncapsulation[
        selectedIndividual,
        opts
      ];
    protoPrint["Encapsulated individual: ",Short[encapsulatedIndividual,2]];

    (* Update population history *)

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

Options[gpEncapsulation] := 
{
  EncapsulationRanks -> exprEncapsulationRANKS,
  EncapsulationSelectionFunction -> 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,
         selectedExpr,
         newSubExpr,
         newExpr,
         uniqueSymbol = {}},
  
  (* 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,
      selectedPattern,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,
    
      (* Generate unique symbol for encapulated tree *)
      (* ... and define it ... *)
      
      uniqueSymbol = Unique[Head[selectedExpr]];
      (** theFunction = (uniqueSymbol := selectedExpr); **)
      
      protoPrint["-- -- uniqueSymbol: ",uniqueSymbol,theFunction];
      
      (* Then set the new subexpression ... *)
      
      newSubExpr = ENCAPS[uniqueSymbol],
      theMessage[exprEncapsulation::constant,selectedExpr];
      newSubExpr = selectedExpr
    ];
  ];
  
  protoPrint["-- -- newSub  = ",newSubExpr];
  
  (* Insert the encapsulated subexpression and return ... *)
    
  newExpr = 
    If[selectedPosition === {} (* root *) ||
       possiblePositions === {},
      newSubExpr,
      ReplacePart[indivExpr, newSubExpr, selectedPosition]
    ];
    
  If[uniqueSymbol === {},
    {{newExpr,{}},{selectedPosition, selectedExpr,{}}},
    {{newExpr,{uniqueSymbol,selectedExpr}},
     {selectedPosition, selectedExpr, newSubExpr} 
    }
  ]
    
] (* end module: exprEncapsulation *)

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

This is the decoding function to decode all encapsulated subexpressions:

doUnfoldExpr[

  indivExpr_,
  encapsList_List,
  opts___
  
] :=

Module[{reducedEncapsList},
  
  reducedEncapsList = DeleteCases[encapsList,{}];
  
  indivExpr //. ENCAPS[x_] :> Last[First[Select[reducedEncapsList,(First[#] === x)&]]]

]; (* end module *)

Examples ...

myExpr =
 f[
   g[a],
   h[b],
   f[1,k[e],3],
   k[1,2,h[c]],
   f[d,k[h[b],2,3]],
   f[h[a],b,1]
 ]

exprEncapsulation[myExpr]

Examples (2) ...

doUnfoldExpr[
  f[a,g[ENCAPS[a1]],c],
  {{a1,ENCAPS[b1]},{b1,b2},{c1,c2}}
]

exprEncapsulation[
  f[k[a],g[b,c],d,h[e]],
  EncapsulationRanks -> exprEncapsulationRANKS,
  EncapsulationSelectionFunction -> rouletteWheelSelectionAttributesOnly
]

exprEncapsulation[
  f[a,b,c],
  EncapsulationRanks -> exprEncapsulationRANKS,
  EncapsulationSelectionFunction -> rouletteWheelSelectionAttributesOnly
]

thePop =
Map[
  gpEncapsulation[
    #,
    {1},
    {}
  ]&,
  {{f[k[a],g[b,c],d,h[e]]}}
]

encapsulationList

doUnfoldExpr[
  First[thePop],
  encapsulationList
]

Operator ranks adjustment

Functions

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}
];

Playground ...

gpOperatorRanks = gpOperatorRanksInitial;
adjustgpOperatorRanks[]

gpOperatorRanks

Graphics ...

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

gaRanksChart3D[gpOperatorRanksList]

PlotStyle[%]

Utilities ...

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

Playground ...

Selection Functions

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

Pattern Selection and Extraction

Pattern Selection

The new expression ranks will be hierarchical:

{
  PRexpr[pattern1,rank1,{PRsubexprs}],
  PRexpr[pattern2,rank2,{PRexpr[pattern21,rank21,{}],
                                          PRexpr[pattern22,rank22,{}] 
                                        }],
  PRexpr[...], ...
}

Please note that in general pattern(i) is not only a single pattern but a pattern with restricting conditions ( p /; ... ).

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

This defines a function which returns a list of patterns due to a hierarchical pattern ranks description as above. The returned list of pattern descriptions {p(1),p(2),p(3),...} means that an expression has to be found where an expression satisfying p(i+1) is a subexpression of p(i).

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
}

Examples ...

ClearAll[patternSelection]

patternSelection[TestexprMutationRANKS]

Expression Extraction

The function patternExtraction returns an expression within expr that matches the hierarchical pattern description of patternList, and additionally the position(s) of inner expressions matching the last pattern of patternList.

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
  ]
];

Examples ...

myExpr =
 f[
   g[a],
   h[b],
   f[1,k[e],3],
   k[1,2,h[c]],
   f[d,k[h[b],2,3]],
   f[h[a],b,1]
 ]

expressionExtraction[myExpr,{_f}]

expressionExtraction[myExpr,{_f,_k}]

expressionExtraction[myExpr,{_f,_k,3}]

Position Extraction

extractPositions returns all positions in posInner whose first elements are identical to the positions in posOuter.

extractPositions[posInner_List,posOuter_List] :=

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

Examples ...

positionsOne = {{3,2},{4},{5,2}};
positionsTwo = {{3},{5}};

extractPositions[positionsOne,positionsTwo]

Examples

Expression templates

Editable templates

exprGenerationPATTERNSsole :=
{
  f[BlankSequence[_g | _h | _f | _k | _Symbol ]],
  
  g[_Symbol],
  
  h[_Symbol],
  
  k[BlankSequence[_Integer | _h]],
  
  a,b,c      
};

Cases[exprGenerationPATTERNS,Blank[_g|_h]]

Template ranks

exprGenerationRANKS = (* selection probabilities *)
  Flatten[
    {
      {1,    (** f **)
      
       1,    (** g **)
       1,    (** h **)
       1,    (** k **)
       
       1,    (** a **)
       1,    (** b **)
       1     (** c **)
    }, 

      Table[1,{Length[constants]}]       (* constants *)
      
      (* Table[1,{Length[patterns]}] *)      (* patterns *)
    },
    Infinity
  ];

Templates collection (do not edit ! )

exprGenerationPATTERNS :=
  Flatten[
  Join[
    exprGenerationPATTERNSsole,
    {
     constants

     (* patterns *)
    }
  ]];

Example ...

myExpr =
 f[
   g[a],
   h[b],
   f[1,k[e],3],
   k[1,2,h[c]],
   f[d,k[h[b],2,3]],
   f[h[a],b,1]
 ]

doGenerateExprWithStart[_f]