Context-sensitive L-Systems with k-contexts

A Simple Implementation

C. Jacob

May 1994

(copyright)

Rule applications

Application of context-sensitive L-system rules

applykLRules[lsystem_LSystem] :=

    Module[{leftContexts, predecessors, rightContexts, successors,
            leftContextPositions, predecessorPositions, rightContextPositions,
            leftContPosition, rightContPosition,
	    skipPositions, substPositions = {},
	        
            skipLeft, skipRight,
	        
	    leftContextPresent = False,
	    rightContextPresent = False,
	    newAxiom},
	
    axiom      = Cases[lsystem,    _AXIOM,  Infinity];
    lRulesTerm = Cases[lsystem,    _LRULES, Infinity];
    lRules     = Cases[lRulesTerm, _LRule,  Infinity];

    numberOfRules = Length[lRules];

    (***
    Print["Axiom: ",axiom];
    Print["Number of rules: ",numberOfRules];

    Print["Rules: ", lRules]; 
    ***)

    leftContexts  = Cases[lRules, _LEFT,  Infinity];
    predecessors  = Cases[lRules, _PRED,  Infinity];
    rightContexts = Cases[lRules, _RIGHT, Infinity];
    successors    = Cases[lRules, _SUCC,  Infinity];

    (***
    Print["leftContexts: ", leftContexts];
    Print["predecessors: ", predecessors];
    Print["rightContexts: ", rightContexts];
    Print["successors: ", successors];
    ***)

    rules = {};
    rules = MapThread[ First[#1] :> Evaluate[First[#2]] &, 
                       {predecessors,successors}];
	
    (***
    Print["rules: ",rules];
    ***)


    skipPositions = Position[axiom, First[skipPattern]];
   	
    Do[
	AppendTo[substPositions,{}];
		

	lWord = predecessors[[rule]] /. PRED[x_] :> x;

        (***
        Print["lWord: ",lWord];
        ***)

	predecessorPositions = Position[axiom,lWord]; 
		

	(** Check for application of L-Rules ... --------------------------------- **)
		
	Do[
            {collectedLeftContexts, 
             collectedLeftContextPositions,
             collectedRightContexts,
             collectedRightContextPositions} =

              getLeftRightContexts[
                axiom,
                predecessorPositions[[i]],
                Length[leftContexts[[rule]]],
                Length[rightContexts[[rule]]]
              ];
                     
            (***
            Print["i: ",i];
            Print["collectedLeftContexts: ", collectedLeftContexts];
            Print["collectedRightContexts: ", collectedRightContexts];
            Print["collectedLeftContextPositions: ", collectedLeftContextPositions];
            Print["collectedRightContextPositions: ", collectedRightContextPositions];

            Print["leftContexts as list: ", leftContexts[[rule]] /. LEFT -> List];
            Print["rightContexts as list: ", rightContexts[[rule]] /. RIGHT[x__] -> List[x]];
            ***)

            leftContextIsOK = Count[{collectedLeftContexts},
                                    leftContexts[[rule]] /. LEFT[x___] -> List[x]];
            rightContextIsOK = Count[{collectedRightContexts},
                                     rightContexts[[rule]] /. RIGHT[x___] -> List[x]];
  
            If[leftContextIsOK > 0 && rightContextIsOK > 0,
	      
              (*** Print["Contexts are OK. Substitution follows."]; ***)       			        
              substPositions[[rule]] = 
                Join[substPositions[[rule]],
                 {{collectedLeftContextPositions,
                   predecessorPositions[[i]],
                   collectedRightContextPositions}}],
              
              (*** Print["Contexts are NOT OK. No substitution will follow."]; ***)
            ],

            {i,1,Length[predecessorPositions]}
	],
	
    	{rule,1,numberOfRules}

    ]; (* end do *)


    (*** Print["substPositions: ",substPositions]; ***)


    (** Now perform the collected substitutions **)
	
    newAxiom = axiom;
	

    Do[
	  Do[
            leftContPositions    = substPositions[[rule,k,1]];
            predecessorPosition  = substPositions[[rule,k,2]];
            rightContPositions   = substPositions[[rule,k,3]];

            (**
            Print["Rule: ",rule,": ",
              leftContPositions,predecessorPosition,rightContPositions];
            **)


            If[leftContPositions == {} && rightContPositions == {}, (* apply an 0L-rule *)

               (** Print["OL-Rule"]; **)
               oldTerm = PRED[Part[axiom,predecessorPosition /. List[x___] -> Sequence[x]]];

               substRule = predecessors[[rule]] :> Evaluate[successors[[rule]]];

               newTerm = oldTerm /. substRule;

              (***
               Print["oldTerm: ",oldTerm];
               Print["substRule: ",substRule];
               Print["newTerm: ",newTerm];
               ***)
            ];

            

            If[leftContPositions != {} && rightContPositions == {}, (* apply a kL-rule (left context) *)

               (** Print["kL-Rule (left context)"]; **)
               oldTerm = tmpSymbol[Map[LEFT[Part[axiom,# /. List[x___] -> Sequence[x]]]&,
                                       leftContPositions] /. List[x___] -> Sequence[x],
                                   PRED[Part[axiom,predecessorPosition /. List[x___] -> Sequence[x]]]
                                  ];

	       substRule = {tmpSymbol[x:leftContexts[[rule]],
                                      predecessors[[rule]]]  :> Evaluate[successors[[rule]]]};

               newTerm = oldTerm /. substRule;

               (***
               Print["oldTerm: ",oldTerm];
               Print["substRule: ",substRule];
               Print["newTerm: ",newTerm];
               ***)
            ];


            If[leftContPositions == {} && rightContPositions != {}, (* apply a kL-rule (right context) *)

               (** Print["kL-Rule (right context)"]; **)
               oldTerm = tmpSymbol[PRED[Part[axiom,predecessorPosition /. List[x___] -> Sequence[x]]],
                                   Map[RIGHT[Part[axiom,# /. List[x___] -> Sequence[x]]]&,
                                       rightContPositions] /. List[x___] -> Sequence[x]
                                  ];

	       substRule = {tmpSymbol[predecessors[[rule]],
	                              y:rightContexts[[rule]]] :> Evaluate[successors[[rule]]]};

               newTerm = oldTerm /. substRule;

               (***
               Print["oldTerm: ",oldTerm];
               Print["substRule: ",substRule];
               Print["newTerm: ",newTerm];
               ***)
            ];


            If[leftContPositions != {} && rightContPositions != {},

	          (** Print["(m,n)L-Rule (left and right context)"]; **)
	          oldTerm = 
		          tmpSymbol[
		            Map[LEFT[Part[axiom,# /. List[x___] -> Sequence[x]]]&,
                       leftContPositions] /. List[x___] -> Sequence[x], 
		            PRED[Part[axiom,predecessorPosition /. List[x___] -> Sequence[x]]],
	    	        (* Part[axiom,substPositions[[rule,k,3]] /. List[x___] -> Sequence[x]], *)
                    Map[RIGHT[Part[axiom,# /. List[x___] -> Sequence[x]]]&,
                        rightContPositions] /. List[x___] -> Sequence[x]
		          ];
	          (** Print["oldTerm: ",oldTerm]; **)

	          substRule = {tmpSymbol[x:leftContexts[[rule]],
	                              predecessors[[rule]],
	                              y:rightContexts[[rule]]] :> Evaluate[successors[[rule]]]};

	           newTerm = oldTerm /. substRule;

               (**
               Print["oldTerm: ",oldTerm];
               Print["substRule: ",substRule];
               Print["newTerm: ",newTerm];
               **)
            ];


	        (** Print["newTerm: ",newTerm]; Print[" "]; **)
	
	        newAxiom = ReplacePart[newAxiom,newTerm,substPositions[[rule,k,2]]];

            (*** Print["newAxiom: ",newAxiom]; ***)

            newAxiom = postProcessingFunction[newAxiom], 

	    {k,1,Length[substPositions[[rule]]]}
	  ],
	  {rule,1,Length[substPositions]}
    ];
	
    newAxiom = First[finalPostProcessingFunction[newAxiom]]
   		
]; (* end module *)

Get left and right context ...

Context extraction

(** Get the positions of the left and right context *)

getLeftRightContextPositions[skipPositions_, predecessorPosition_,
                             leftContextPositions_, rightContextPositions_] :=

    Module[{skipLeft, skipRight, leftContPosition, rightContPosition},

	{skipLeft, skipRight} = 
	    getLeftRightSkips[skipPositions, predecessorPosition];

	leftContPosition = 
	    Cases[leftContextPositions,
		  Join[Drop[predecessorPosition,-1],
		       {Last[predecessorPosition]-skipLeft}]];

	rightContPosition = 
	    Cases[rightContextPositions,
		  Join[Drop[predecessorPosition,-1],
		       {Last[predecessorPosition]+skipRight}]];

	(** Print["left-right-cont-Positions: ",leftContPosition, rightContPosition]; **)

	{If[leftContPosition != {}, First[leftContPosition], {}], 
	 If[rightContPosition != {}, First[rightContPosition], {}]}

    ]; (* end module *)

Skipping patterns ...

(** Get the positions of possible left and right contexts **)

getLeftRightSkips[skipPositions_, predecessorPosition_] :=

    Module[{skipLeft = 1,
	    skipRight = 1
	   },
			
	While[
	    Count[skipPositions,
	    Join[Drop[predecessorPosition,-1],
	         {Last[predecessorPosition]-skipLeft}]] > 0,
						      
	    skipLeft++;
				
	]; (* end while *)
				
	While[
	    Count[skipPositions,
	    Join[Drop[predecessorPosition,-1],
	         {Last[predecessorPosition]+skipRight}]] > 0,
						      
	    skipRight++;
			
	]; (* end while *)
		
	{skipLeft, skipRight}
		
    ]; (* end module *)

Printing of L-rules

(** Print the L-rules and its axiom **)

printLRules[axiom_, lRules_] :=

    Module[{leftContexts, predecessors, rightContexts, successors,
            leftContextString, predecessorString, rightContextString, successorString},

	leftContexts  = Map[ #[[1]] &, lRules];
	predecessors  = Map[ #[[2]] &, lRules];
	rightContexts = Map[ #[[3]] &, lRules];
	successors    = Map[ #[[4]] &, lRules];

	Print["Axiom: ",axiom];
	Print[" "];

	Do[
	    Print["Rule ",rule,": ",leftContexts[[rule]]," < ",
                                    predecessors[[rule]]," > ",
	                            rightContexts[[rule]]," -> ",
	                            successors[[rule]]
	    ],
	    {rule,1,Length[predecessors]}
	];

    ]; (* end module *)

Iterative L-rules application

(* Iterative application of L-rules **)
(*
runKLSystem[axiom_AXIOM,lrules_LRULES, iterations_Integer] :=
    ((*** printLRules[axiom,lRules]; ***)
     NestList[applykLRules[LSystem[#,lrules]]&, axiom, iterations] )

*)

(* Iterative application of L-rules **)

runKLSystem[lsys_LSystem, iterations_Integer] :=

  Module[
    {axiom = Part[lsys,Apply[Sequence,First[Position[lsys,AXIOM[___]]]]],
     lrules = Part[lsys,Apply[Sequence,First[Position[lsys,LRULES[___]]]]]
    },
    
    NestList[applykLRules[LSystem[#,lrules]]&, axiom, iterations]
  ];

Context processing

Left context

(** Definitions for left contexts ... ------------------------------- **)

(** ----------------------------------------------------------------- **)

getLeftContext::usage =
"getLeftContext[TERM,POSITION]:\n
 Returns the left context and the left context position of a subterm\n
 at position POSITION in term TERM.\n
 Note: POSITION must be a proper position within term TERM.\n
";

getLeftContext[term_, position_] :=

  Module[{sTerm, sTermArity},
  
    If[position == {}, Return[{{},{}}]];

    lastPositionIndex = Last[position];
    restPosition = Drop[position, -1];
    
    If[ Length[position] == 1, (* position is from level one *)
      sTerm = term; levelIsOne = True,
      sTerm = term[[restPosition /. List -> Sequence]]; levelIsOne = False
    ];
    sTermArity = Length[sTerm];
    
    Switch[ Last[position],
    
      1, If[levelIsOne == True, 
            {leftContext,leftContextPosition} = {{},{}},
            {leftContext,leftContextPosition} = getLeftContext[term,restPosition]],
            
      _, leftContextPosition = Append[restPosition, lastPositionIndex-1];
         leftContext = term[[leftContextPosition /. List -> Sequence]]
    ];
    
    {leftContext,leftContextPosition}
  ];
  
  
(** ----------------------------------------------------------------- **)

getLeftContextList::usage =
"getLeftContextList[TERM,POSITION,N]:\n
 Returns the left contexts and the left context positions\n
 (up to a length of N) of a subterm at position POSITION in term TERM.\n
 Note: POSITION must be a proper position within term TERM.\n
";

getLeftContextList[term_, position_, n_] :=

  Module[{},
  
    NestList[getLeftContext[term, #[[2]]]&, {{},position}, n]
  ];

Right context

(** Definitions for right contexts ... ------------------------------- **)

(** ----------------------------------------------------------------- **)

getRightContext::usage =
"getRightContext[TERM,POSITION]:\n
 Returns the right context and the right context position of a subterm\n
 at position POSITION in term TERM.\n
 Note: POSITION must be a proper position within term TERM.\n
";

getRightContext[term_, position_] :=

  Module[{sTerm, sTermArity},
  
    If[position == {}, Return[{{},{}}]];
    
    lastPositionIndex = Last[position];
    restPosition = Drop[position, -1];
    
    If[ Length[position] == 1, (* position is from level one *)
      sTerm = term; levelIsOne = True,
      sTerm = term[[restPosition /. List -> Sequence]]; levelIsOne = False
    ];
    sTermArity = Length[sTerm];
    
    Switch[ Last[position],
    
      sTermArity, 
         If[levelIsOne == True, 
            {rightContext,rightContextPosition} = {{},{}},
            {rightContext,rightContextPosition} = getRightContext[term,restPosition]],
            
      _, rightContextPosition = Append[restPosition, lastPositionIndex+1];
         rightContext = term[[rightContextPosition /. List -> Sequence]]
    ];
    
    {rightContext,rightContextPosition}
  ];



(** ----------------------------------------------------------------- **)

getRightContextList::usage =
"getRightContextList[TERM,POSITION,N]:\n
 Returns the right contexts and the right context positions\n
 (up to a length of N) of a subterm at position POSITION in term TERM.\n
 Note: POSITION must be a proper position within term TERM.\n
";

getRightContextList[term_, position_, n_] :=

  Module[{},
  
    NestList[getRightContext[term, #[[2]]]&, {{},position}, n]
  ];

Left and right context

(** Definitions for left and right contexts ... --------------------- **)

(** ----------------------------------------------------------------- **)

getLeftRightContexts[term_, 
                     position_List, 
                     leftContextSize_Integer,
                     rightContextSize_Integer] :=

  Module[{leftContextList, rightContextList},

    leftContextList =
      Reverse[Drop[getLeftContextList[axiom, position, leftContextSize],1]];
    rightContextList =
      Reverse[Drop[getRightContextList[axiom, position, rightContextSize],1]];

   {
    Map[First[#]&,leftContextList],
    Map[Last[#]&,leftContextList],
    Map[First[#]&,rightContextList],
    Map[Last[#]&,rightContextList]
   }

  ];

Post processing

postProcessingFunction = (#)&;

finalPostProcessingFunction = (# //. SUCC[x___] -> x)&;