Section GoToCurrent.
Definition atStart (t : tape sigSim) (tps : list (tape sig)) : Prop :=
t = midtape nil (inl START) (map inr (encode_list _ tps) ++ [inl STOP]).
Definition atCons (t : tape sigSim) (tps1 tps2 : list (tape sig)) (tp : tape sig) : Prop :=
t = midtape (map inr (rev (removelast (encode_list _ tps1))) ++ [inl START])
(inr (sigList_cons))
(map inr (map sigList_X (encode_tape tp)) ++ map inr (encode_list _ tps2) ++ [inl STOP]).
Definition atNil (t : tape sigSim) (tps : list (tape sig)) : Prop :=
t = midtape (map inr (rev (removelast (encode_list _ tps))) ++ [inl START]) (inr (sigList_nil)) [inl STOP].
Definition atCons_current_niltape (t : tape sigSim) (tps1 tps2 : list (tape sig)) : Prop :=
t = midtape
(inr (sigList_cons) :: map inr (rev (removelast (encode_list _ tps1))) ++ [inl START])
(inr (sigList_X NilBlank))
(map inr (encode_list _ tps2) ++ [inl STOP]).
Definition atCons_current_leftof (t : tape sigSim) (tps1 tps2 : list (tape sig)) (r : sig) (rs : list sig) :=
t = midtape
(inr (sigList_cons) :: map inr (rev (removelast (encode_list _ tps1))) ++ [inl START])
(inr (sigList_X (LeftBlank true)))
(inr (sigList_X (UnmarkedSymbol r)) ::
map (fun s => inr (sigList_X (UnmarkedSymbol s))) rs ++ inr (sigList_X (RightBlank false)) ::
map inr (encode_list _ tps2) ++ [inl STOP]).
Definition atCons_current_midtape (t : tape sigSim) (tps1 tps2 : list (tape sig)) (ls : list sig) (m : sig) (rs : list sig) :=
t = midtape
(map (fun s => inr (sigList_X (UnmarkedSymbol s))) ls ++ (* [ls] is reversed twice *)
inr (sigList_X (LeftBlank false)) :: inr (sigList_cons) :: map inr (rev (removelast (encode_list _ tps1))) ++ [inl START])
(inr (sigList_X (MarkedSymbol m)))
(map (fun s => inr (sigList_X (UnmarkedSymbol s))) rs ++ inr (sigList_X (RightBlank false)) ::
map inr (encode_list _ tps2) ++ [inl STOP]).
Definition atCons_current_rightof (t : tape sigSim) (tps1 tps2 : list (tape sig)) (l :sig) (ls : list sig) :=
t = midtape
(inr (sigList_X (UnmarkedSymbol l)) ::
map (fun s => inr (sigList_X (UnmarkedSymbol s))) ls ++ (* [ls] is reversed twice *)
inr (sigList_X (LeftBlank false)) :: inr (sigList_cons) :: map inr (rev (removelast (encode_list _ tps1))) ++ [inl START])
(inr (sigList_X (RightBlank true)))
(map inr (encode_list _ tps2) ++ [inl STOP]).
Definition atCons_current (t : tape sigSim) (tps1 tps2 : list (tape sig)) (tp : tape sig) :=
match tp with
| niltape _ => atCons_current_niltape t tps1 tps2
| leftof r rs => atCons_current_leftof t tps1 tps2 r rs
| midtape ls m rs => atCons_current_midtape t tps1 tps2 ls m rs
| rightof l ls => atCons_current_rightof t tps1 tps2 l ls
end.
Definition tape_dir (t : tape sig) : option move :=
match t with
| niltape _ => None
| leftof _ _ => Some Lmove
| midtape _ _ _ => Some Nmove
| rightof _ _ => Some Rmove
end.
Definition isMarked' (s : sigSim) : bool :=
match s with
| inr (sigList_X s) => isMarked s
| _ => false
end.
Definition IsCons_Rel : pRel sigSim bool 1 :=
fun tin '(yout, tout) =>
(forall tps1 tps2 tp,
atCons tin[@Fin0] tps1 tps2 tp ->
atCons tout[@Fin0] tps1 tps2 tp /\
yout = true) /\
(forall tps,
atNil tin[@Fin0] tps ->
atNil tout[@Fin0] tps /\
yout = false).
Definition IsCons : pTM sigSim bool 1 :=
Switch ReadChar
(fun (s : option sigSim) =>
match s with
| Some (inr (sigList_cons)) => Return Nop true
| Some (inr (sigList_nil)) => Return Nop false
| _ => Return Nop default
end).
Definition IsCons_steps := 2.
Definition GoToCurrent_Rel : pRel sigSim (option move) 1 :=
fun tin '(yout, tout) =>
forall (tps1 tps2 : list (tape sig)) (tp : tape sig),
atCons tin[@Fin0] tps1 tps2 tp ->
atCons_current tout[@Fin0] tps1 tps2 tp /\
yout = tape_dir tp.
Definition GoToCurrent : pTM sigSim (option move) 1 :=
MoveToSymbol isMarked' id;;
Switch ReadChar
(fun (c : option sigSim) =>
match c with
| Some (inr (sigList_X (RightBlank true))) => Return Nop (Some Rmove)
| Some (inr (sigList_X (LeftBlank true))) => Return Nop (Some Lmove)
| Some (inr (sigList_X (MarkedSymbol _))) => Return Nop (Some Nmove)
| Some (inr (sigList_X NilBlank)) => Return Nop (None)
| _ => Return Nop None
end).

Lemma GoToCurrent_Realise : GoToCurrent ⊨ GoToCurrent_Rel.