(* BijectiveRules *)

(* This package contains functions to compute with right bijective and left bijective cellular automaton rules. *)
(* Please report any bugs you encounter. *)


(* :Context: BijectiveRules` *)

(* :Author: Eric S. Rowland *)
(*          http://math.rutgers.edu/~erowland *)

(* :Date: 10/27/05 *)

(* :Package Version: 0.9 *)

(* :Mathematica Version: 5.0 *)


(*BeginPackage["BijectiveRules`"]*)

ApplyRule::usage = "ApplyRule[{num, k, r}, cells] gives the color of the cell yielded by the sequence cells under the given rule."

ApplyRightBijectiveRuleInverse::usage = "ApplyRightBijectiveRuleInverse[{num, k, r}, cells, rcell] gives the color of the cell C to the right of the sequence cells so that Append[cells, C] yields rcell under the given rule."

ColorCycles::usage = "ColorCycles[{num, k, r}] lists the possible cycles of tail colors for the k-color rule num depending on r+1 cells."

Evolve::usage = "Evolve[{num, k, r}, listofrows, numrows] continues the evaluation of listofrows for (positive or negative) numrows additional steps.  Evolve[{num, k, r}, listofrows, {numrows1, ..., numrowsk}] continues the evaluation for numrows1 steps, ..., numrowsk steps."

FlipRow::usage = "FlipRow[list] gives the left-right reflection of a row of the form {lefttailcolor, row} or {row, righttailcolor}."

Lambda::usage = "Lambda[initialcondition, row] gives the number of leftmost entries to which two lists agree."

LeftBijectiveRules::usage = "LeftBijectiveRules[k, r] lists the rule numbers of all left bijective, k-color, range [0,r] rules."
RightBijectiveRules::usage = "RightBijectiveRules[k, r] lists the rule numbers of all right bijective, k-color, range [-r,0] rules."
LeftOrRightBijectiveRules::usage = "LeftOrRightBijectiveRules[k, r] lists the rule numbers of all k-color, range [-r,0] rules that are either left bijective or right bijective."

LeftBijectiveQ::usage = "LeftBijectiveQ[{num, k, r}] returns True if the k-color rule number num depending on r+1 cells is left bijective and False otherwise."
RightBijectiveQ::usage = "RightBijectiveQ[{num, k, r}] returns True if the k-color rule number num depending on r+1 cells is right bijective and False otherwise."

LeftfulPredecessor::usage = "LeftfulPredecessor[{num, k, r}, {row, tailcolor}] gives the predecessor of row with an infinite leftful history under the given left bijective rule."
RightfulPredecessor::usage = "RightfulPredecessor[{num, k, r}, {tailcolor, row}] gives the predecessor of row with an infinite rightful history under the given right bijective rule."

LeftfulSuccessor::usage = "LeftfulSuccessor[{num, k, r}, {row, tailcolor}] gives the successor of row under the given rule."
RightfulSuccessor::usage = "RightfulSuccessor[{num, k, r}, {tailcolor, row}] gives the successor of row under the given rule."

LeftRightReflection::usage = "LeftRightReflection[{num, k, r}] gives the k-color, left-right reflection of rule number num depending on r+1 cells."

ToArray::usage = "ToArray[listofrows] turns a list of rightful or leftful rows into an array suitable for plotting with ArrayPlot.  ToArray[listofrows, pad] pads the appropriate side with pad tail cells."

ValidRuleQ::usage = "ValidRuleQ[{num, k, r}] returns True if there is a k-color rule number num depending on r+1 cells and False otherwise."


(*Begin["`Private`"]*)

BRCanonicalRotation[list_List] := First[Sort[NestList[RotateLeft, list, Length[list] - 1]]]

BRPeriod[list_List] := Take[list, Module[{i = 1, positions = Rest[Flatten[Position[list, list[[1]], 1]]]}, 
   If[Length[positions] > 100, positions = Select[Complement[positions, {Length[list]}], list[[# + 1]] === list[[2]] & ]; 
      If[Last[list] === First[list], AppendTo[positions, Length[list]]]]; 
    While[i <= Length[positions] && ( !(SameQ @@ Most[#] && Last[#] === Take[First[#], Length[Last[#]]]) & )[
       Partition[list, positions[[i]] - 1, positions[[i]] - 1, {1, 1}, {}]], i++]; positions[[i]] - 1]]

BRRotateLeftTo[list_List, patt_] := RotateLeft[list, (If[# != {}, #[[1,1]] - 1, 0] & )[
    Position[list, patt, 1, 1, Heads -> False]]]


ApplyRule[{num_, k_, r_}, cells_List] /; Length[cells] == r + 1 := IntegerDigits[num, k, k^(r + 1)][[
   k^(r + 1) - cells . k^Range[r, 0, -1]]]
ApplyRightBijectiveRuleInverse[{num_, k_, r_}, cells_List, rcell_] /; RightBijectiveQ[{num, k, r}] && Length[cells] == r := 
  Append[Rest[cells], Select[Table[{IntegerDigits[i, k, r + 1], IntegerDigits[num, k, k^(r + 1)][[
        k^(r + 1) - IntegerDigits[i, k, r + 1] . k^Range[r, 0, -1]]]}, {i, k^(r + 1) - 1, 0, -1}], 
     Most[First[#1]] == cells && Last[#1] == rcell & ][[1,1,-1]]]

ColorCycles[{num_, k_, r_}] := With[{graph = Table[i -> ApplyRule[{num, k, r}, Table[i, {r + 1}]], {i, 0, k - 1}]}, 
   Union[Table[BRCanonicalRotation[BRPeriod[Drop[NestList[#1 /. graph & , i, 3*k], k]]], {i, 0, k - 1}]]]

Evolve[rule_List, array_List, (rows_Integer)?NonNegative] /; Head[array[[1,1]]]===List && LeftBijectiveQ[rule] := 
  Join[array, Rest[NestList[LeftfulSuccessor[rule, #1] & , Last[array], rows]]]
Evolve[rule_List, array_List, (rows_Integer)?NonNegative] /; Head[array[[1,2]]]===List && RightBijectiveQ[rule] := 
  Join[array, Rest[NestList[RightfulSuccessor[rule, #1] & , Last[array], rows]]]
Evolve[rule_List, array_List, (rows_Integer)?Negative] /; Head[array[[1,1]]]===List := 
  Join[Reverse[Rest[NestList[LeftfulPredecessor[rule, #1] & , First[array], -rows]]], array]
Evolve[rule_List, array_List, (rows_Integer)?Negative] /; Head[array[[1,2]]]===List := 
  Join[Reverse[Rest[NestList[RightfulPredecessor[rule, #1] & , First[array], -rows]]], array]
Evolve[rule_List, array_List, rowses_List] := Fold[Evolve[rule, ##1] & , array, rowses]

FlipRow[{tail_Integer, row_List}] := {Reverse[row], tail}
FlipRow[{row_List, tail_Integer}] := {tail, Reverse[row]}

Lambda[initcon_List, row_List] /; Length[initcon] == Length[row] := (If[#1 != {}, #1[[1,1]] - 1, Length[initcon]] & )[
   Position[row - initcon, _?(#1 != 0 & ), {1}, 1]]

LeftBijectiveRules[k_, r_] := Sort[(First[LeftRightReflection[{#1, k, r}]] & ) /@ RightBijectiveRules[k, r]]
RightBijectiveRules[k_, r_] := (FromDigits[Join @@ #1, k] & ) /@ Tuples[Permutations[Range[k] - 1], k^r]
LeftOrRightBijectiveRules[k_, r_] := Union[Flatten[({#1, LeftRightReflection[{#1, k, r}]} & ) /@ RightBijectiveRules[k, r]]]

LeftBijectiveQ[{num_, k_, r_}] := RightBijectiveQ[LeftRightReflection[{num, k, r}]]
RightBijectiveQ[{num_, k_, r_}] := 
  Length[Union[Table[Append[Most[IntegerDigits[i, k, r + 1]], IntegerDigits[num, k, k^(r + 1)][[
        k^(r + 1) - IntegerDigits[i, k, r + 1] . k^Range[r, 0, -1]]]], {i, k^(r + 1) - 1, 0, -1}]]] == k^(r + 1)

LeftfulPredecessor[rule_List, {row_List, tail_Integer}] := FlipRow[RightfulPredecessor[LeftRightReflection[rule], {tail, Reverse[row]}]]
RightfulPredecessor[rule_List, {tail_, row_List}] := 
  With[{newtail = Last[BRRotateLeftTo[First[Select[ColorCycles[rule], MemberQ[#1, tail] & ]], tail]]}, 
   {newtail, Last /@ Rest[FoldList[ApplyRightBijectiveRuleInverse[rule, ##1] & , Table[newtail, {rule[[3]]}], row]]}]

LeftfulSuccessor[rule_List, {row_List, tail_Integer}] := {#[[2]],Reverse[#[[1]]]} & [RightfulSuccessor[LeftRightReflection[rule], {tail, Reverse[row]}]]
RightfulSuccessor[rule_List, {tail_Integer, row_List}] := {ApplyRule[rule, Table[tail, {rule[[3]] + 1}]], 
   (ApplyRule[rule, #1] & ) /@ Partition[Join[Table[tail, {rule[[3]]}], row], rule[[3]] + 1, 1]}

LeftRightReflection[{num_, k_, r_}] := 
  {FromDigits[Last /@ Reverse[Sort[Transpose[{Reverse /@ IntegerDigits[Range[k^(r + 1) - 1, 0, -1], k, r + 1], 
        IntegerDigits[num, k, k^(r + 1)]}]]], k], k, r}

ToArray[array_List, r_:5] /; Head[array[[1,1]]]===List := (Join[#1[[1]], Table[#1[[2]], {r}]] & ) /@ array
ToArray[array_List, r_:5] /; Head[array[[1,2]]]===List := (Join[Table[#1[[1]], {r}], #1[[2]]] & ) /@ array

ValidRuleQ[{num_, k_, r_}] := True

(*End[]

Protect[Evaluate[$Context <> "*"]]

EndPackage[]*)

(* Examples:
RightfulSuccessor[{86, 2, 2}, {0, {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}]
RightfulPredecessor[{86, 2, 2}, {0, {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}]
Evolve[{86, 2, 2}, {{0, {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}}, -10]
ArrayPlot[ToArray[Evolve[{86, 2, 2}, {{0, Prepend[Table[0, {100}], 1]}}, {-100, 100}]]];
*)