Expression Generation

C. Jacob

January 1995

(copyright)

Imported Packages

Needs["DiscreteMath`Tree`"];

Needs["Graphics`Graphics`"];

Needs["Graphics`Graphics3D`"];

Expression rules

Constants

numbers = Range[1,10];

constants = 
  Flatten[ numbers ];

Patterns

patterns = 
{ 
  anExpression[], 
  anExpressionSequence[], 
  aBlank[],
  aSequence[],
  aNull[]
};

Parameters

maxSequenceLength = 10;

Expression rules

Editable rules

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

Rules collection (do not edit ! )

exprGenerationPATTERNS :=
  Flatten[
  Join[
    exprGenerationPATTERNSsole,
    {
     constants

     (* patterns *)
    }
  ]];

Expression ranks

Generation

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

Mutation

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

Crossover

exprCrossoverRANKS = 
{
  {_g,1},
  {_h,1},
  {_k,1}
};

Shrink

exprShrinkRANKS =
{
  {_f,1},
  {_k,2}
};

Permutation

exprPermutationRANKS =
{ 
  {_f,1},
  {_k,1}
};

Encapsulation

exprEncapsulationRANKS =
{
  {_k,1},
  {_g,1},
  {_h,1}
};

Expression generation

Initialization ...

ClearAll[generateExpr];

ClearAll[blankExpr];
ClearAll[constantExpr];
ClearAll[newExpr];

ClearAll[generateExprSequence];

Expression generation

ClearAll[generateExpr]

Functions

generateExpr[
  x_Blank | 
  x_Condition | 
  x_Pattern,
  opts___
  
] := ((* Print["generateExpr (Blank, Condition, Pattern) ..."]; *)
      blankExpr[x,opts]);

generateExpr[
  x_Alternatives,
  opts___
  
] := ((* Print["generateExpr (Alternatives) ..."]; *)
      generateExpr[
        selectRandomElement[x /. Alternatives -> List],
        opts
      ]);

generateExpr[
  x_BlankSequence /; Length[x] > 0,
  opts___
  
] := ((* Print["generateExpr (BlankSequence, length > 0) ..."]; 
      Print[First[x]]; *)
      generateExprSequence[First[x],opts]);

generateExpr[
  x_BlankSequence /; Length[x] == 0,
  opts___
  
] := ((* Print["generateExpr (BlankSequence, length == 0) ..."]; *)
      generateExprSequence[BLANK,opts]);

generateExpr[
  x_ /; MemberQ[Union[Map[Head,constants]],Head[x]],
  opts___
  
] := ((* Print["generateExpr (constant) ..."]; *) x);

generateExpr[
  x_,
  opts___
  
] := ((* Print["generateExpr (Blank) ..."]; *)
      Map[generateExpr[#,opts]&,x,Heads -> False]);

generateExpr[
  DEFAULTTERM,
  opts___
  
] := ((* Print["generateExpr (DEFAULTTERM) ..."]; *)
      DEFAULTTERM);

generateExpr[
  opts___
  
] := ((* Print["generateExpr () ..."]; *)
      generateExpr[
       rouletteWheelSelection[
         GenerationPatterns /. {opts} /. Options[generateExpr],
         GenerationRanks /. {opts} /. Options[generateExpr]
       ]
      ]
     );

Options[generateExpr] :=
{
  GenerationPatterns -> Join[exprGenerationPATTERNS,patterns],
  GenerationRanks -> Join[exprGenerationRANKS,Table[1,{Length[patterns]}]]
};

Expression sequence generation

Functions

ClearAll[generateExprSequence]

generateExprSequence[BLANK,opts___] := 
  ((* Print["generateExprSequence (BLANK) ..."]; *)
   Table[
     doGenerateExprWithStart[_],
     {Random[Integer,{1,maxSequenceLength}]}
   ] /. List -> Sequence);

generateExprSequence[h_,opts___] := 
  ((* Print["generateExprSequence (Blank[]) ..."]; *)
   Table[
     FixedPoint[
       generateExpr[#,opts]&,
       selectRandomElementCond[
         GenerationPatterns /. {opts} /. Options[generateExprSequence],
         Blank[h],
         GenerationRanks /. {opts} /. Options[generateExprSequence]
       ],
       1
     ],
     {Random[Integer,{1,maxSequenceLength}]}
   ] /. List -> Sequence);

generateExprSequence[h_Alternatives,opts___] :=
  ((* Print["generateExprSequence (Alternatives) ..."]; *)
   Table[
     doFixedPoint[
       selectRandomElementCond[
         GenerationPatterns /. {opts} /. Options[generateExprSequence],
         h,
         GenerationRanks /. {opts} /. Options[generateExprSequence]
       ],
       IterationDepth /. {opts} /. Options[generateExprSequence],
       opts
     ],
     {Random[Integer,{1,maxSequenceLength}]}
   ] /. List -> Sequence);

Options[generateExprSequence] := 
{
  GenerationPatterns -> Join[exprGenerationPATTERNS,patterns],
  GenerationRanks -> Join[exprGenerationRANKS,Table[1,{Length[patterns]}]],
  
  IterationDepth -> Infinity
};

Blank expression generation

Function

blankExpr[pattern_,opts___] := 
 ((* Print["blankExpr (Blank[]) ..."]; *)
  selectRandomElementCond[
    GenerationPatterns /. {opts} /. Options[blankExpr],
    pattern,
    GenerationRanks /. {opts} /. Options[blankExpr]]
 );

Options[blankExpr] := 
{
  GenerationPatterns -> exprGenerationPATTERNS,
  GenerationRanks -> exprGenerationRANKS
};

Constant expression generation

Function

constantExpr[x_,opts___] := 
 ((* Print["consantExpr (Blank[]) ..."]; *)
  selectRandomElement[constants]
 );

Options[constantExpr] := 
{
  GenerationPatterns -> Join[exprGenerationPATTERNS,patterns],
  GenerationRanks -> Join[exprGenerationRANKS,Table[1,{Length[patterns]}]]
};

Playground ...

FullForm[f[__h]]

expr = 
doGenerateExprWithStart[
  _f
]

lSystemGenPatterns :=
{
  LSYSTEM[_AXIOM | _LRULES],
 
  AXIOM[],
  LRULES[]
};

lSystemGenRanks = (* selection probabilities *)
  Flatten[
    {
      {1,    (** LSYSTEM **)
       1,
       1
      }, 

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

doGenerateExprWithStart[
  _LSYSTEM,
  GenerationPatterns -> lSystemGenPatterns,
  GenerationRanks -> lSystemGenRanks
]

?doGenerateExprWithStart

Functions

Expression generation

doGenerateExpr[ (** this function should not be used any more **)
                (** use doGenerateExprWithStart[_] instead    **)
  listOfExprPatterns_List, 
  exprPatternRanks_List
  
] :=
  Module[{startExpr},
    startExpr = rouletteWheelSelection[listOfExprPatterns,
                                       exprPatternRanks];
    Print["doGenerateExpr:"];
    Print["-- listOfExprPatterns: ",listOfExprPatterns];
    Print["-- exprPatternRanks: ",exprPatternRanks];
    Print["-- startExpr: ",startExpr];
                                  
    Return[ First[ FixedPoint[generateExpr,startExpr] ] ];
];

ClearAll[doGenerateExprWithStart]

doGenerateExprWithStart::startSymbolNotFound =
  "Expression with head `1` not found.";
  
doGenerateExprWithStart::startPatternNotFound =
  "Expression with pattern `1` not found.";

doGenerateExprWithStart[

  startPattern_,
  opts___

] :=
  
  Module[
    {resultExpr,
     possiblePositions,
     selectedPosition,
     
     listOfExprPatterns =
       GenerationPatterns /. {opts} /. Options[doGenerateExprWithStart],
     exprPatternRanks =
       GenerationRanks /. {opts} /. Options[doGenerateExprWithStart],
          
     iterDepth =
       IterationDepth /. {opts} /. Options[doGenerateExprWithStart]
    },
          
    (**Print["doGenerateExprWithStart:"];**)
    protoPrint["-- startPattern: ",FullForm[startPattern]];
    protoPrint["-- iterDepth: ",iterDepth];
    
    If[Head[startPattern] === Blank,
    
      possiblePositions = 
        Position[listOfExprPatterns, startPattern];
      selectedPosition = selectRandomElement[possiblePositions];
      
      (**
      protoPrint["-- possiblePositions: ",possiblePositions];
      protoPrint["-- selectedPositions: ",selectedPositions];
      **)
      
      If[selectedPosition === {},
        Message[doGenerateExprWithStart::startPatternNotFound,
                startPattern];
        DEFAULTEXPRESSION,
      
        startExpr = Part[listOfExprPatterns,
                         selectedPosition /. List -> Sequence];
    
        protoPrint["possiblePositions = ",possiblePositions];
        protoPrint["selected          = ",selectedPosition];
        protoPrint["startExpr         = ",startExpr];
        
        doFixedPoint[startExpr,iterDepth,opts]
      ],
      
      doFixedPoint[startPattern,iterDepth,opts]
    ]
];

Options[doGenerateExprWithStart] := 
 {
   GenerationPatterns -> exprGenerationPATTERNS,
   GenerationRanks -> exprGenerationRANKS,
   
   IterationDepth -> Infinity
 };

doFixedPoint::unstableExpr =
 "No stable expression found for start pattern `1` 
  after `2` trials.";

doFixedPoint[

  startPattern_,
  iterDepth_,
  opts___

] :=
  
Module[{maximumTrials =
          MaxTrials /. {opts} /. Options[doFixedPoint],
        trialCounter = 0,
        exprIsUnstable = True,
        resultExpr},

  (* First iterate for iterDepth iterations. *)
  (* Then check if expression is stable ...  *)
  (* If not, repeat generation process       *)
 
 While[trialCounter < maximumTrials && exprIsUnstable,
 
   resultExpr =
     FixedPoint[generateExpr[#,opts]&,startPattern,iterDepth];
   
   If[resultExpr ===
      FixedPoint[generateExpr[#,opts]&,resultExpr,1],
      exprIsUnstable = False
   ];
   
   trialCounter++;
   
 ]; (* end while *)
 
 If[exprIsUnstable === True,
   Message[doFixedPoint::unstableExpr,
     startPattern,maximumTrials];
   DEFAULTEXPRESSION,
   resultExpr
 ]
 
]; (* end module *)

Options[doFixedPoint] := 
 {
   MaxTrials -> 3
 };

doGenerateExprWithStart[_f, IterationDepth -> 10]

doFixedPoint[_g,3]

generateExpr[_g]

Utilities

selectRandomElement[searchList_List] :=
  If[searchList === {},{},searchList[[Random[Integer,{1,Length[searchList]}]]]];

selectRandomElementCond::emptySearchList =
 "Searchlist is empty.";
 
selectRandomElementCond::noExpressionFound =
 "Cannot select expression with pattern `1` in `2`.";

selectRandomElementCond[searchList_List,
  pattern_,
  searchListAttr_List:{}] :=

  Module[{positionList,
          positionListAttributes,
          randomPosition,
          selectedElement},
    (**
    Print["selectRandomElementCond:"];
    Print["-- searchList: ",searchList];
    Print["-- pattern: ",pattern];
    Print["-- searchListAttr: ",searchListAttr];
    **)
    
    If[searchList === {},
       
       Message[selectRandomElementCond::emptySearchList];
       {},

       positionList = Position[searchList,pattern,1, Heads -> False];
       (* Print["positionList: ",positionList]; *)
       
       If[positionList === {},
         Message[selectRandomElementCond::noExpressionFound,FullForm[pattern],
           searchList];
         DEFAULTEXPRESSION,
         
         positionListAttributes = 
           Map[Part[searchListAttr,# /. List -> Sequence]&, positionList];
         (* Print["positionListAttributes: ",positionListAttributes]; *)

         randomPosition = rouletteWheelSelection[
                          positionList,
                          Flatten[positionListAttributes]];
         (* Print["randomPosition: ",randomPosition]; *)

         selectedElement = Part[searchList, 
                                randomPosition /. List -> Sequence];
       
         selectedElement
       ]
    ]
  ]; (* end module *)

rouletteWheelSelection[elements_List,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 *)

	elements[[index]]

]; (* end module *)

Examples

expr = 
doGenerateExprWithStart[
  _f
]

?doGenerateExprWithStart