Computing Expansions in Infinitely Many Cantor Real Bases via a Single Transducer
Notebook companion permits to compute the finite transducers discussed in the paper
E. Charlier, P. Popoli, M. Rigo (2025)

Part of the abstract: “We develop a new approach where a single transducer associated with a fixed real number r, computes the B-expansion of r but for an infinite family of Cantor bases B given as input. This point of view contrasts with traditional computational models for which the numeration system is fixed.”

Main functions to be executed first

(* auxiliary function called to build graphs *)

Given a real number r and a list l={β1,β2,...}, the function outputs a list of digits a1,a2,... and a normalized remainder such that r=a1/β1 + a2/(β1β2) +... and the remainder is in "normalized form"

f[{r_,l_}]:=Module[
{digit=0,
(* consider the sequence of partial products in l *)
seq=Table[Apply[Times,Take[l,i]],{i,1,Length[l]}],
remainder=r,output={}},
For[i=1,i<=Length[l],
digit=0;
(* find the maximal digit to remove *)
While[FullSimplify[remainder-digit/seq[[i]]]>0,
digit++];digit--;
remainder=FullSimplify[remainder-digit/seq[[i]]];
(* we add a new digit to the output sequence *)
AppendTo[output,digit];
i++;
];
(* when done, a normalization occurs in the β-transformation, Last[seq] contains the product of those elements *)
{output,FullSimplify[Last[seq]*remainder]} 
]

Here is an example :

f[{Pi/4,{Sqrt[2],2,2,2,2,2}}]

This means that Pi/4 can be written as 1/Sqrt[2] + 1/(Sqrt[2] 2^4) + 1/(Sqrt[2] 2^5) and here is the normalized remainder :

(Pi/4-1/Sqrt[2]-1/(Sqrt[2] 2^4)-1/(Sqrt[2] 2^5))Apply[Times,{Sqrt[2],2,2,2,2,2}]//Simplify

(* the arguments are the starting vertex and wlist is the alphabet containing the real bases, the last argument can be omitted, it permits to track the progress of computations if set to True *)

buildTransducer[start_,wlist_,verbose_:False]:=
(* q contains the lists of states of the transducers *)
Module[{q={start},toprocess={start},g={},detect,new},
(* toprocess is the list of states to be processed ; g will contain the list of transitions *)
While[Length[toprocess]>0,
(* for the first state to be processed, we apply all the bases from wlist and record the "detected states" *)
detect=Table[
FullSimplify[Last[f[{First[toprocess],{x}}]]],{x,wlist}];
(* we update the list g of transitions accordingly *)
AppendTo[g,
Table[
{First[toprocess]\[DirectedEdge]FullSimplify[Last[f[{First[toprocess],{x}}]]],
(* our choice of labeling transitions *)
Row[{Subscript["e",Position[wlist,x][[1,1]]],"|",StringPart[ToString[First[f[{First[toprocess],{x}}]]],2]}]},
{x,wlist}]];
(* newly detected states are those in detect but not obtained in previous stages so, already stored in q or toprocess *)
new=Complement[detect,q,toprocess];
q=Union[q,detect];
(* this print option permits to follow computations *)
If[verbose,Print[Length[q]]]; 
(* the fist element to be processed may be removed from the list and the newly detected states added *)
toprocess=Drop[toprocess,1]; 
toprocess=Union[toprocess,new];
];
(* output the transitions of the graph *)
DeleteDuplicates[Flatten[g,1]]
]

An example

The result is a list whose elements are pairs of the form {a->b, (RowDefault[(Subscript["e", i]), "|", "d"])} where a, b are vertices (real numbers), the (Subscript["e", i])’s represent the element of the set E of bases and finally d is the output digit

t=buildTransducer[1/2,{GoldenRatio,GoldenRatio^3}]

It is then easy to represent the graph, one can use the VertexLabels -> “Name” to add the value of the vertices

GraphPlot[t,
VertexSize->0.03,EdgeStyle->{{Thick,Purple}},EdgeLabelStyle->Directive[20]]

Examples from the paper

Figure 3

t=buildTransducer[1,{2,3}];

GraphPlot[t,
VertexLabels->"Name",VertexSize->0.03,EdgeStyle->{{Thick,Purple}},EdgeLabelStyle->Directive[20]]

t=buildGraph[1/5,{2,3},False];

GraphPlot[t,
VertexLabels->"Name",VertexSize->0.03,EdgeStyle->{{Thick,Purple}},EdgeLabelStyle->Directive[20]]

Example 3.15

t=buildTransducer[1/2,{GoldenRatio,2 GoldenRatio+1},False];

GraphPlot[t,
VertexLabels->None,VertexStyle->{1/2->Red},VertexSize->0.04,EdgeStyle->{{Thick,Purple}},EdgeLabelStyle->Directive[20]]

Example 3.13 with 180 states

t=buildTransducer[932/3885,{2,3}];

A few elements of the list :

Take[t,5]

Here is the list of states of this transducer :

VertexList[Graph[Map[#[[1]]&,t]]]

Let us check that we have indeed 180 states :

Length[%]

Building by hand the subgraph obtained from 932/3885 when only reading e1 e2 or e2 e1

temp=Select[t,MatchQ[#[[1]],932/3885\[DirectedEdge]_]&]

Select[t,MatchQ[#[[1]],temp[[1,1,2]]\[DirectedEdge]_]&&MatchQ[#[[2]],Row[List[Subscript["e",2],"|",_]]]&]

Select[t,MatchQ[#[[1]],temp[[2,1,2]]\[DirectedEdge]_]&&MatchQ[#[[2]],Row[List[Subscript["e",1],"|",_]]]&]

temp=Select[t,MatchQ[#[[1]],%[[1,1,2]]\[DirectedEdge]_]&]

Select[t,MatchQ[#[[1]],temp[[1,1,2]]\[DirectedEdge]_]&&MatchQ[#[[2]],Row[List[Subscript["e",2],"|",_]]]&]

Select[t,MatchQ[#[[1]],temp[[2,1,2]]\[DirectedEdge]_]&&MatchQ[#[[2]],Row[List[Subscript["e",1],"|",_]]]&]

temp=Select[t,MatchQ[#[[1]],%[[1,1,2]]\[DirectedEdge]_]&]

Select[t,MatchQ[#[[1]],temp[[1,1,2]]\[DirectedEdge]_]&&MatchQ[#[[2]],Row[List[Subscript["e",2],"|",_]]]&]

Select[t,MatchQ[#[[1]],temp[[2,1,2]]\[DirectedEdge]_]&&MatchQ[#[[2]],Row[List[Subscript["e",1],"|",_]]]&]

temp=Select[t,MatchQ[#[[1]],%[[1,1,2]]\[DirectedEdge]_]&]

Select[t,MatchQ[#[[1]],temp[[1,1,2]]\[DirectedEdge]_]&&MatchQ[#[[2]],Row[List[Subscript["e",2],"|",_]]]&]

Select[t,MatchQ[#[[1]],temp[[2,1,2]]\[DirectedEdge]_]&&MatchQ[#[[2]],Row[List[Subscript["e",1],"|",_]]]&]

temp=Select[t,MatchQ[#[[1]],%[[1,1,2]]\[DirectedEdge]_]&]

Select[t,MatchQ[#[[1]],temp[[1,1,2]]\[DirectedEdge]_]&&MatchQ[#[[2]],Row[List[Subscript["e",2],"|",_]]]&]

Select[t,MatchQ[#[[1]],temp[[2,1,2]]\[DirectedEdge]_]&&MatchQ[#[[2]],Row[List[Subscript["e",1],"|",_]]]&]

t=Join[,,,,,,,,,,,,,,]//DeleteDuplicates

GraphPlot[t,
VertexLabels->None,VertexStyle->{932/3885->Red},VertexSize->0.18,EdgeStyle->{{Thick,Purple}},EdgeLabelStyle->Directive[20]]

Example 4.9 with 2-walk property

β=(X/.Solve[X^3-X-1==0,X])[[1]]

t=buildTransducer[1,{β,β^3}];

GraphPlot[t,
VertexLabels->None,VertexStyle->{1->Red},VertexSize->0.04,EdgeLabelStyle->Directive[20],EdgeStyle->{1\[DirectedEdge]->{Thickness[Large],Cyan},\[DirectedEdge]->{Thickness[Large],Green},\[DirectedEdge]->{Thickness[Large],Blue},\[DirectedEdge]->{Thickness[Large]},\[DirectedEdge]1->{Thickness[Large],Green},\[DirectedEdge]->{Thickness[Large]},\[DirectedEdge]->{Thickness[Large]},\[DirectedEdge]1->{Thickness[Large],Blue},\[DirectedEdge]->{Thickness[Large]}}]

Examples of Section 5 about connectedness

γ1=1+Sqrt[2];
γ2=2+2Sqrt[2];
γ3=4+3Sqrt[2];
γ4=5+4Sqrt[2];
γ5=1+2^(1/3)+4^(1/3);

t=buildTransducer[1,{γ1,γ2}];

GraphPlot[t,
VertexLabels->"Name",VertexSize->0.03,EdgeStyle->{{Thick,Purple}},EdgeLabelStyle->Directive[20]]

ConnectedGraphQ[Graph[Map[#[[1]]&,t]]]

t=buildTransducer[1,{γ3,γ4}];

GraphPlot[t,
VertexLabels->"Name",VertexSize->0.1,VertexStyle->{1->Red},EdgeStyle->{{Thick,Purple}},EdgeLabelStyle->Directive[20]]

ConnectedGraphQ[Graph[Map[#[[1]]&,t]]]

(* also depicted in Fig. 8*)

t=buildTransducer[1,{γ1,γ1^2}];

GraphPlot[t,
VertexLabels->"Name",VertexSize->0.08,VertexStyle->{1->Red},EdgeStyle->{{Thick,Purple}},EdgeLabelStyle->Directive[20]]

t=buildTransducer[1,{γ1^2,γ1^3}];

GraphPlot[t,
VertexLabels->"Name",VertexSize->0.08,VertexStyle->{1->Red},EdgeStyle->{{Thick,Purple}},EdgeLabelStyle->Directive[20]]

t=buildTransducer[1,{γ1^2,γ2^2}];

GraphPlot[t,
VertexLabels->"Name",VertexSize->0.08,VertexStyle->{1->Red},EdgeStyle->{{Thick,Purple}},EdgeLabelStyle->Directive[20]]

The following transducer is discussed in the paper but not represented because of its size

Timing[t=buildTransducer[1,{γ5^2,γ5^3}]]

VertexList[Graph[Map[#[[1]]&,t]]]//Length

ConnectedGraphQ[Graph[Map[#[[1]]&,t]]]