BeginPackage["CSM`TuringMacros`", "CSM`Turing`"]

(* calling convention:
   a macro is an instruction sequence that starts in state 1
   and halts in state 0. It does not use the tape to the left
   of its initial position. The square to the left of its first
   argument is empty. Arguments are separated by one empty square.
   The head is initially one square before the first argument.
   It should end in the same position with the result following it.
*)

relocate::usage = "relocate[instrs, offset, return] adds offset to all states
	and changes state 0 into return."

compose::usage = "compose[instruction lists...] assembles the instruction lists
	into a sequential program."

while::usage = "while[ instrs ] loops over the instructions while the symbol
        under the head is not empty."

(* useful sequences *)

right::usage = "right moves the head on place to the right."
left::usage = "left moves the head on place to the left."
noop::usage = "noop does nothing."
skip::usage = "skip[n] skips n arguments. negative n skips left."
copy::usage = "copy[n, m] copies n arguments over m more and halts before
	the copy."
shiftleft::usage = "shiftleft[n] shifts n arguments one place to the left."
eat1::usage = "eat1[n] deletes the first of n arguments."

Begin["`Private`"]

relocate[instr_List, offset_, return_] :=
    instr /. {instruction[st_, sy_, nsy_, mv_, 0]  :>
                instruction[st+offset, sy, nsy, mv, return],
              instruction[st_, sy_, nsy_, mv_, nst_] :>
                instruction[st+offset, sy, nsy, mv, nst+offset]}

maxState[{}] = 0
maxState[instr_List] := Max[ state /@ instr ]

SetAttributes[ compose, {Flat, OneIdentity} ]

compose[instr1_, instr2_] :=
    With[{offset = maxState[instr1]},
        Join[ relocate[instr1, 0, offset+1],
              relocate[instr2, offset, 0] ]
    ]

compose[instr1_] := instr1

(* looping *)

while[ instr_ ] :=
       Join[ { instruction[1, b, b, s, 0],
               instruction[1, m, m, s, 2] },
             relocate[ instr, 1, 1 ]
       ]

(* primitive movements *)

right = {
    instruction[1, b, b, r, 0],
    instruction[1, m, m, r, 0]
}
left = {
    instruction[1, b, b, l, 0],
    instruction[1, m, m, l, 0]
}

noop = {
    instruction[1, b, b, s, 0],
    instruction[1, m, m, s, 0]
}

(* skip arg *)

skip1 =
    compose[
        right,
        while[ {instruction[1, m, m, r, 0]} ]
    ]

skipback1 =
    compose[
        left,
        while[ {instruction[1, m, m, l, 0]} ]
    ]

(* skip n args *)

skip[n_?Negative] := skipback[-n]
skip[n_] := compose @@ Table[skip1, {n}]
skipback[n_] := compose @@ Table[skipback1, {n}]


(* copy an arg over n others and return after original *)

copy1[n_] :=
compose[
 right,
 while[
  compose[
    { instruction[1, m, b, s, 0] }, (* b is sentinel *)
    skip[n+2],
    { instruction[1, b, m, r, 0] }, (* write 1 *)
    skip[-(n+2)],
    { instruction[1, b, m, r, 0] }] (* restore 1 *)
 ]
]

(* copy n arguments over m and stop before the copy

.arg1.arg2...argn.argn1...argm  -> 
^

.arg1.arg2...argn.argn1...argm.arg1.arg2...argn.
                              ^
*)

copy[n_] := copy[n, n]

copy[n_, m_] :=
compose[
    compose @@ Table[copy1[m-1], {n}],
    skip[m-n]
]

(* shift arg left one pos, ending 2 after the shifted arg *)

(*  .11111.  -->   11111..
    ^                    ^
*)

shiftl = {
  instruction[1, b, m, r, 2], (* write 1 *)
  instruction[2, m, m, r, 2], (* skip 1s *)
  instruction[2, b, b, l, 3], (* end *)
  instruction[3, m, b, r, 0]  (* erase 1 *)
}


 (* shift n args left by one pos. *)
 
shiftleft[n_] :=
compose[
  compose @@ Table[ shiftl, {n} ],
  skip[-(n+1)]
]

(* eat an argument of n args *)

eat1[n_] :=
compose[
  right,
  while[
    compose[
        { instruction[1, m, b, s, 0] }, (* erase it *)
        shiftleft[n],
        right
    ]
  ],
  shiftleft[n-1]
]

End[]

Protect[ relocate, compose, while, right, left, noop, skip, copy, shiftleft, eat1 ]

EndPackage[]
