Section DoActions.
Variable (acts : Vector.t (option sig * move) n).
(* Abuse [UNKNOWN] as a special marker, to return to the place where we inserted the symbol with shifting *)
Definition isReturnMarker (s : sigSim) : bool :=
match s with
| inl UNKNOWN => true
| _ => false
end.
(* The more complicated part is writing, because we may have to alocate more memory by shifting *)
Definition DoWrite_Rel (d : option move) (s : sig) : pRel sigSim unit 1 :=
ignoreParam
(fun tin tout =>
forall tps1 tps2 tp,
tape_dir tp = d ->
atCons_current tin[@Fin0] tps1 tps2 tp ->
atCons_current tout[@Fin0] tps1 tps2 (tape_write tp (Some s))).
Definition DoWrite (d : option move) (s : sig) : pTM sigSim unit 1 :=
match d with
| Some Lmove => (* [leftof] ~> shift left and change boundary symbol to [LeftBlank false] *)
Shift_L (fun _ => false) (inl UNKNOWN);;
MoveToSymbol isReturnMarker id;;
WriteMove (inr (sigList_X (MarkedSymbol s))) Lmove;;
WriteMove (inr (sigList_X (LeftBlank false))) Rmove
| Some Rmove => (* [rightof] ~> shift right and change boundary symbol to [RightBlank false] *)
Shift (fun _ => false) (inl UNKNOWN);;
MoveToSymbol_L isReturnMarker id;;
WriteMove (inr (sigList_X (MarkedSymbol s))) Rmove;;
WriteMove (inr (sigList_X (RightBlank false))) Lmove
| Some Nmove => (* [midtape] ~> just write the symbol *)
Write (inr (sigList_X (MarkedSymbol s)))
| None => (* [midtape] ~> we need to shift left and right and insert [RightBlank false] and [LeftBlank false] *)
Shift (fun _ => false) (inl UNKNOWN);;
MoveToSymbol_L isReturnMarker id;;
Shift_L (fun _ => false) (inr (sigList_X (MarkedSymbol s)));;
MoveToSymbol isReturnMarker id;;
WriteMove (inr (sigList_X (LeftBlank false))) Rmove;;
Move Rmove;;
WriteMove (inr (sigList_X (RightBlank false))) Lmove
end.
Definition DoWrite_steps (d : option move) (tps1 tps2 : list (tape sig)) :=
match d with
| Some Lmove => 37 + 8 * length (encode_list _ tps1)
| Some Rmove => 37 + 8 * length (encode_list _ tps2)
| Some Nmove => 1
| None => 73 + 8 * length (encode_list _ tps1) + 8 * length (encode_list _ tps2)
end.
Definition DoWrite_T (d : option move) : tRel sigSim 1 :=
fun tin k => exists tps1 tps2 tp, tape_dir tp = d /\ atCons_current tin[@Fin0] tps1 tps2 tp /\ DoWrite_steps d tps1 tps2 <= k.
Definition DoMove_Rel (d : option move) (m : move) : pRel sigSim unit 1 :=
ignoreParam
(fun tin tout =>
forall tps1 tps2 tp,
tape_dir tp = d ->
atCons_current tin[@Fin0] tps1 tps2 tp ->
atCons_current tout[@Fin0] tps1 tps2 (tape_move tp m)).
Definition toggle_marked (s : sigTape sig) : sigTape sig :=
match s with
| UnmarkedSymbol s => MarkedSymbol s
| MarkedSymbol s => UnmarkedSymbol s
| LeftBlank b => LeftBlank (negb b)
| RightBlank b => RightBlank (negb b)
| NilBlank => NilBlank
end.
Definition ToggleMarked_Rel : pRel sigSim unit 1 :=
ignoreParam (fun tin tout => forall ls m rs,
tin[@Fin0] = midtape ls (inr (sigList_X m)) rs ->
tout[@Fin0] = midtape ls (inr (sigList_X (toggle_marked m))) rs).
Definition ToggleMarked : pTM sigSim unit 1 :=
Switch ReadChar
(fun (s : option sigSim) =>
match s with
| Some (inr (sigList_X m)) => Write (inr (sigList_X (toggle_marked m)))
| _ => Nop
end).
(* this should take constant time *)
Definition DoMove (d : option move) (m : move) : pTM sigSim unit 1 :=
match d with
| Some Lmove => match m with
| Nmove => Nop
| Lmove => Nop
| Rmove => ToggleMarked;; Move Rmove;; ToggleMarked
end
| Some Rmove => match m with
| Nmove => Nop
| Rmove => Nop
| Lmove => ToggleMarked;; Move Lmove;; ToggleMarked
end
| Some Nmove => match m with
| Nmove => Nop
| Rmove => ToggleMarked;; Move Rmove;; ToggleMarked
| Lmove => ToggleMarked;; Move Lmove;; ToggleMarked
end
| None => Nop
end.
Definition DoMove_steps := 9.
Arguments DoMove : simpl never.
(* First write, then move *)
Definition DoAction_Rel (d : option move) (a : option sig * move) : pRel sigSim unit 1 :=
ignoreParam
(fun tin tout =>
forall (tps1 tps2 : list (tape sig)) (tp : tape sig),
tape_dir tp = d ->
atCons_current tin[@Fin0] tps1 tps2 tp ->
atCons_current tout[@Fin0] tps1 tps2 (doAct tp a)).
Definition DoAction (d : option move) (a : option sig * move) : pTM sigSim unit 1 :=
match (fst a) with
| Some s => DoWrite d s;; DoMove (Some Nmove) (snd a) (* after wrting, we have a [midtape] *)
| None => DoMove d (snd a)
end.
Definition DoAction_steps (d : option move) (a : option sig * move) (tps1 tps2 : list (tape sig)) :=
match (fst a) with
| Some s => 1 + DoWrite_steps d tps1 tps2 + DoMove_steps
| None => DoMove_steps
end.
Definition DoAction_T (d : option move) (a : option sig * move) : tRel sigSim 1 :=
fun tin k => exists tps1 tps2 tp, tape_dir tp = d /\ atCons_current tin[@Fin0] tps1 tps2 tp /\ DoAction_steps d a tps1 tps2 <= k.
Definition DoActions_Step_Rel (i : Fin.t n) : pRel sigSim (Fin.t n + unit) 1 :=
fun tin '(yout, tout) =>
(forall tps1 tps2 tp,
(length tps1 =? fin_to_nat i) = true ->
(length tps1 + (1 + length tps2) =? n) = true ->
atCons tin[@Fin0] tps1 tps2 tp ->
match tps2 with
| tp' :: tps2' =>
atCons tout[@Fin0] (tps1 ++ [doAct tp acts[@i]]) tps2' tp' /\
match finSucc_opt i with
| Some i' => yout = inl i'
| None => False
end
| nil =>
atNil tout[@Fin0] (tps1 ++ [doAct tp acts[@i]]) /\
yout = inr tt
end) /\
(forall tps,
atNil tin[@Fin0] tps ->
atNil tout[@Fin0] tps /\
yout = inr tt).
Definition opt_to_sum_unit (X : Type) (x : option X) : X + unit :=
match x with
| Some x => inl x
| None => inr tt
end.
Definition DoActions_Step (i : Fin.t n) : pTM sigSim (Fin.t n + unit) 1 :=
If IsCons
(Switch GoToCurrent
(fun (d : option move) =>
Return (DoAction d (acts[@i]);; GoToNext) (opt_to_sum_unit (finSucc_opt i))))
(Return Nop (inr tt)).
Definition DoActions_Step_steps_cons i tps1 tps2 tp :=
3 + IsCons_steps + GoToCurrent_steps tp + DoAction_steps (tape_dir tp) (acts[@i]) tps1 tps2 + GoToNext_steps (doAct tp acts[@i]).
Definition DoActions_Step_steps_nil := 1 + IsCons_steps.
Definition DoActions_Step_T (i : Fin.t n) : tRel sigSim 1 :=
fun tin k =>
(exists tps1 tps2 tp,
(length tps1 =? fin_to_nat i) = true /\
(length tps1 + (1 + length tps2) =? n) = true /\
atCons tin[@Fin0] tps1 tps2 tp /\
DoActions_Step_steps_cons i tps1 tps2 tp <= k) \/
(exists tps, atNil tin[@Fin0] tps /\ DoActions_Step_steps_nil <= k).
Definition DoActions_Loop : Fin.t n -> pTM sigSim unit 1 := StateWhile DoActions_Step.
Definition DoActions_Loop_Rel (i : Fin.t n) : pRel sigSim unit 1 :=
fun tin '(yout, tout) =>
(forall tps1 tps2 tp,
(length tps1 =? fin_to_nat i) = true ->
(length tps1 + (1 + length tps2) =? n) = true ->
atCons tin[@Fin0] (map_vect_list (@doAct sig) acts tps1) tps2 tp ->
atNil tout[@Fin0] (map_vect_list (@doAct sig) acts (tps1 ++ tp :: tps2))
) /\
(forall tps,
atNil tin[@Fin0] tps ->
atNil tout[@Fin0] tps).
Definition DoActions_Loop_steps_nil := DoActions_Step_steps_nil.
Fixpoint DoActions_Loop_steps_cons (i : Fin.t n) tps1 tps2 tp :=
match tps2 with
| nil => DoActions_Step_steps_cons i tps1 [] tp
| tp' :: tps2' =>
match finSucc_opt i with
| None => 0 (* can't happen *)
| Some i' =>
1 + DoActions_Step_steps_cons i tps1 tps2 tp + DoActions_Loop_steps_cons i' (tps1 ++ [doAct tp acts[@i]]) tps2' tp'
end
end.
Definition DoActions_Loop_T (i : Fin.t n) : tRel sigSim 1 :=
fun tin k =>
(exists tps1 tps2 tp,
(length tps1 =? fin_to_nat i) = true /\
(length tps1 + (1 + length tps2) =? n) = true /\
atCons tin[@Fin0] tps1 tps2 tp /\
DoActions_Loop_steps_cons i tps1 tps2 tp <= k) \/
(exists tps, atNil tin[@Fin0] tps /\ DoActions_Loop_steps_nil <= k).

Lemma DoActions_Loop_Terminates (i : Fin.t n) : projT1 (DoActions_Loop i) ↓ DoActions_Loop_T i.