BeginPackage["CSM`Turing`", "CSM`Tape`", "Utilities`FilterOptions`"]

(* Symbols, b is the empty symbol *)

b::usage = "b is the default blank."
m::usage = "m is the default mark."

(* instruction data type *)

l::usage = "l is a move to the left."
r::usage = "r is a move to the right."
s::usage = "s is the empty move."

instruction::usage = "instruction[state, symbol, newsym, move, newst]
        builds an instruction."

state::usage = "state[instr] gives the state of an instruction."
symbol::usage = "symbol[instr] gives the (old) sumbol of an instruction."
newsymbol::usage = "newsymbol[instr] gives the symbol after an instruction."
move::usage = "move[instr] gives the head move of an instruction."
newstate::usage = "newstate[instr] gives the new state after an instruction."

(* configuration data type *)

config::usage = "config[s0, t0, p0] is aconfiguration with state s0, tape t0,
	 and with head position p0."
state::usage = state::usage <>
        "state[config] is the state of a configuration."
tape::usage = "tape[config] is the tape of a configuration."
head::usage = "head[config] is the head position of a configuration."
symbol::usage = "head[config] is the symbol under the head in a configuration."

(* simulation *)

nextConfiguration::usage = " nextConfiguration[config, instructions]
	performs a step of the machine."
initialConfiguration::usage = "initialConfiguration[list]
	is the configuration with state 1, tape given by list."
run::usage = "run[config, instructions, n:Infinity] simulates
	the machine staring inconfiguration config until it halts,
	but for  at most n steps. run[list, ...] uses the list for
	the initial tape an starts in state 1."
runList::usage = "runList[args] gives the intermediate configurations of
	the simulation with run[args]."

(* plotting *)

PlotTuring::usage = "PlotTuring[configlist, opts...] plots the configurations
	(obtained by runList[])."
Columns::usage = "Columns -> n is an option of PlotTuring that gives the
	number of columns to draw."

b = "_"
m = "*"

nextConfiguration::noinstr =
        "No instruction with state `1` and symbol `2` found."

Begin["`Private`"]

(* instruction data type *)

instruction[state_, symbol_, newsym_, move_, newst_] :=
        {state, symbol} -> {newsym, move, newst}

state[instruction[state_, symbol_, newsym_, move_, newst_]] := state
symbol[instruction[state_, symbol_, newsym_, move_, newst_]] := symbol
newsymbol[instruction[state_, symbol_, newsym_, move_, newst_]] := newsym
move[instruction[state_, symbol_, newsym_, move_, newst_]] := move
newstate[instruction[state_, symbol_, newsym_, move_, newst_]] := newst

(* configuration data type *)

state[config[s_, t_, head_]] := s
tape[config[s_, t_, head_]] := t
head[config[s_, t_, head_]] := head
symbol[config[s_, t_, head_]] := t[head]

(* state transition *)

nextConfiguration[c_config/; state[c]==0, instructions_] := c

moverules = Dispatch[{r -> 1, l -> -1, s -> 0}]

nextConfiguration[c_config, instr_List | instr_Dispatch] :=
    Module[{newst, newsym, move},
        {newsym, move, newst} = {state[c], symbol[c]} /. instr;
        If[ Head[newst] === Symbol,
            Message[ nextConfiguration::noinstr, state[c], symbol[c]];
            Return[c] ];
        config[ newst,
                update[tape[c], newsym, head[c]],
                head[c] + move /. moverules
              ]
    ]

(* initial configuration *)

initialConfiguration[l_List] := config[1, newTape[l, b], 1]

(* execution history *)

run[c_config, instr_List | instr_Dispatch, n_:Infinity] :=
        FixedPoint[ nextConfiguration[#, instr]&, c, n ]

run[init_List, instructions_, n_:Infinity] :=
        run[initialConfiguration[init], instructions, n]

runList[c_config, instr_List | instr_Dispatch, n_:Infinity] :=
    Module[{configs},
        configs = FixedPointList[ nextConfiguration[#, instr]&, c, n ];
        If[ Length[configs] < n + 1, Drop[configs, -1], configs ]
    ]

runList[init_List, instructions_, n_:Infinity] :=
        runList[initialConfiguration[init], instructions, n]

(* graphics *)

nonblank[s_] := If[ s === b, "", s ] (* suppress blanks *)

rect[{x0_, y0_}, {x1_, y1_}] :=
        Line[{{x0, y0}, {x1, y0}, {x1, y1}, {x0, y1}, {x0, y0}}]
rect[{x0_, y0_}, {x1_, y1_}, fill_] :=
        { fill, Rectangle[{x0, y0}, {x1, y1}] }

drawConfig[ c_config, y0_, x0_, x1_ ] :=
    Module[{i, cells},
        cells = Table[ { rect[{i, y0}, {i+1, y0+1}],
                         Text[nonblank[tape[c][i]], {i+1/2, y0+1/2}] },
                       {i, x0, x1} ];
        Join[ { AbsoluteThickness[0.25],
                rect[{head[c], y0}, {head[c]+1, y0+1}, GrayLevel[0.7]]},
              cells,
              { Text[state[c], {x0 - 1/2, y0+1/2}, {1, 0}] }
            ]
    ]

maxl = 8

Options[PlotTuring] = {Columns->1}

PlotTuring[ configs_List, opts___ ] :=
    Module[{y = 0, rows, cols, gr, gropt, n},
        minx = Min[ head /@ configs,  low[tape[configs[[-1]]]], 0 ];
        maxx = Max[ head /@ configs, high[tape[configs[[-1]]]], maxl ];
        rows = Table[ y -= 1.5; drawConfig[configs[[i]], y, minx, maxx],
                      {i, 1, Length[configs]}];
        cols = Columns /. {opts} /. Options[PlotTuring];
        gropt = { FilterOptions[Graphics, opts],
                  Axes->None, AspectRatio->Automatic,
                  PlotRange->{{minx-2.2, maxx+1.1}, All} };
        If[ cols > 1,
              n = Ceiling[Length[rows]/cols];
              gr = Partition[ rows, n ];
              If[ n cols != Length[rows],
                  AppendTo[gr, Take[rows, -(Length[rows] - n(cols-1))]] ];
              gr = Graphics[#, gropt]& /@ gr;
              gr = GraphicsArray[ gr,
                    {FilterOptions[GraphicsArray, opts], PlotRange->All} ];
            ,
              gr = Graphics[rows, gropt];
        ];
        Show[ gr ]
    ]

PlotTuring[ c_config, opts___ ] := PlotTuring[{c}, opts]

End[]

Protect[state, symbol, newsymbol, move, newstate,
        head, config,  nextConfiguration, initialConfiguration, runList, run,
        PlotTuring, Columns]
Protect[r, l, s]

EndPackage[]
