Section Univ.
(* Actually, we build a Universal Turing Machine for each alphabet [sigM] *)
Variable (sigM : finType).
Notation sigGraph := (sigList (sigPair (sigPair (option sigM) sigState) (sigPair (option sigM * move) sigState))).
(* We need to import all the Variables and Instances from the other file *)
(* The alphabet of [Univ] *)
Variable (sig : finType).
Variable (retr_sigGraph_sig : Retract sigGraph sig).
Variable (retr_sigTape_sig : Retract sigM sig).
(* Encoding of the current state number *)
Local Existing Instance LowLevel.retr_sigCurrentStateNumber_sigGraph.
Local Existing Instance LowLevel.retr_sigCurrentStateNumber_sig.
(* Encoding of the current state (= halt bit + number) *)
Local Existing Instance LowLevel.retr_sigCurrentState_sigGraph.
Local Existing Instance LowLevel.retr_sigCurrentState_sig.
(* Encoding of final bit of the current state *)
Local Existing Instance LowLevel.retr_sigCurrentStateFinal_sigGraph.
Local Existing Instance LowLevel.retr_sigCurrentStateFinal_sig.
(* Encoding of the next state *)
Local Existing Instance LowLevel.retr_sigNextState_sigGraph.
Local Existing Instance LowLevel.retr_sigNextState_sig.
(* Encoding the current symbol *)
Local Existing Instance LowLevel.retr_sigCurrentSymbol_sigGraph.
Local Existing Instance LowLevel.retr_sigCurrentSymbol_sig.
(* Encoding of actions *)
Local Existing Instance LowLevel.retr_act_sigGraph.
Local Existing Instance LowLevel.retr_act_sig.
(* Encoding of the keys for [Lookup] ([option sig * Q]) *)
Local Existing Instance LowLevel.retr_key_sigGraph.
Local Existing Instance LowLevel.retr_key_sig.
(* Encoding of the value for [Lookup] ([option sig * Q]) *)
Local Existing Instance LowLevel.retr_value_sigGraph.
Local Existing Instance LowLevel.retr_value_sig.
Local Existing Instance LowLevel.Encode_graph.
Local Existing Instance LowLevel.Encode_optSigM.
Local Existing Instance LowLevel.Encode_action.
(* We have to define a [RegSpec] for [containsWorkingTape] *)
Definition ContainsWorkingTape (tp : tape sigM) : RegSpec sig :=
Custom (fun t => containsWorkingTape _ t tp).
(* The first high-level rule *)
Definition DoAction'_size (a : option sigM * move) : Vector.t (nat->nat) 2 :=
[| (*0*) id; (*1*) DoAction_size a |]. (* The entry for (*0*) is irrelevant, since it is a [Custom]. *)
(* The low-level machines are still verified using Realisation. The Hoare-framework doesn't make sense for low-level machines. Thus, we just convert the relations to Hare triples. *)
Notation "'ContainsState' q" :=
(Contains (LowLevel.retr_sigCurrentState_sig _) (halt q, index q)) (at level 0).
Notation "'ContainsState_size' q s" :=
(Contains_size (LowLevel.retr_sigCurrentState_sig _) (halt q, index q) s) (at level 0).
Definition IsFinal_size' : Vector.t (nat->nat) 2 :=
[| (*0*) id; IsFinal_size |].
Definition ReadCurrent'_size : Vector.t (nat->nat) 2 :=
[| (*0*) id; ReadCurrent_size |].
(* We now have rules for all auxiliary low-level machines of [Univ_Step], and can verify it now. *)
Notation "'ContainsTrans' M" :=
(Contains (retr_sigGraph_sig) (graph_of_TM M)) (at level 0).
Notation "'ContainsTrans_size' M s" :=
(Contains_size (retr_sigGraph_sig) (graph_of_TM M) s) (at level 0).
Local Arguments graph_of_TM : simpl never.
Definition Univ_Step_size (M : TM sigM 1) (tp : tape sigM) (q : state M) : Vector.t (nat->nat) 6 :=
(* Note that the size function for tape 0 is semantically irrelevant because there is no size associated to this (working) tape *)
if halt q
then [|IsFinal_size|]@>>[|Fin3|]
else let (q', act) := trans (q, [|current tp|]) in
([|IsFinal_size|]@>>[|Fin3|]) >>>
([|ReadCurrent_size|]@>>[|Fin3|]) >>>
([|Constr_pair_size (current tp)|]@>>[|Fin2|]) >>>
([|Reset_size (current tp)|] @>> [|Fin3|]) >>>
(Lookup_size (graph_of_TM M) (current tp, (halt q, index q)) @>> [|Fin1; Fin2; Fin3; Fin4; Fin5|]) >>>
([|CasePair_size0 act[@Fin0];
CasePair_size1 act[@Fin0]|] @>> [|Fin2; Fin3|]) >>>
([|DoAction_size act[@Fin0]|] @>> [|Fin3|]).
Definition Univ_Step_steps_ConstrPair (tp : tape sigM) :=
Constr_pair_steps (current tp).
Definition Univ_Step_steps_ResetSymbol (tp : tape sigM) :=
Reset_steps (current tp).
Definition Univ_Step_steps_Lookup (M : TM sigM 1) (q : state M) (tp : tape sigM) :=
Lookup_steps (current tp, (halt q, index q)) (graph_of_TM M).
Definition Univ_Step_steps_CasePair (a : option sigM * move) :=
CasePair_steps a.
Definition Univ_Step_steps_Translate (M : TM sigM 1) (q' : state M) :=
Translate_steps (halt q', index q').
Definition Univ_Step_steps_IsFinal (M : TM sigM 1) (q : state M) (tp : tape sigM) :=
if halt q
then 0
else
let (q', acts) := trans (q, [|current tp|]) in
6 + ReadCurrent'_steps + Univ_Step_steps_ConstrPair tp + Univ_Step_steps_ResetSymbol tp +
Univ_Step_steps_Lookup q tp + Univ_Step_steps_CasePair acts[@Fin0] + DoAction'_steps + Univ_Step_steps_Translate q'.
Definition Univ_Step_steps (M : TM sigM 1) (q : state M) (tp : tape sigM) : nat :=
1 + IsFinal_steps (halt q) + Univ_Step_steps_IsFinal q tp.
Definition Univ_Step : pTM sig^+ (option unit) 6 :=
If (IsFinal _ @ [|Fin2; Fin3|])
(Return Nop (Some tt))
(Return
(ReadCurrent' _ _ @ [|Fin0; Fin3|];;
Constr_pair (FinType(EqType (option sigM))) (FinType(EqType sigState)) ⇑ LowLevel.retr_key_sig _ @ [|Fin3; Fin2|];;
Reset _ @ [|Fin3|];;
Lookup _ _ ⇑ retr_sigGraph_sig @ [|Fin1; Fin2; Fin3; Fin4; Fin5|];;
CasePair (FinType(EqType(option sigM * move))) (FinType(EqType(sigState))) ⇑ LowLevel.retr_value_sig _ @ [|Fin2; Fin3|];;
DoAction' _ _ @ [|Fin0; Fin3|];;
Translate (LowLevel.retr_sigNextState_sig _) (LowLevel.retr_sigCurrentState_sig _) @ [|Fin2|]) None).
Fixpoint Univ_steps (M : TM sigM 1) (q : state M) (tp : tape sigM) (k : nat) : nat :=
match k with
| 0 => Univ_Step_steps q tp
| S k' =>
if halt q
then Univ_Step_steps q tp
else let (q', tp') := step (mk_mconfig q [|tp|]) in
1 + Univ_Step_steps q tp + Univ_steps q' tp'[@Fin0] k'
end.
(* Complete Correctness: If [M] terminates, so does [Univ]. Note that we need a new triple for this. We also don't need spaces in this triple. *)

Lemma Univ_steps_eq (M : TM sigM 1) (q : state M) (tp : tape sigM) (k : nat) :
Univ_steps q tp k =
match k with
| 0 => Univ_Step_steps q tp
| S k' =>
if halt q
then Univ_Step_steps q tp
else let (q', tp') := step (mk_mconfig q [|tp|]) in
1 + Univ_Step_steps q tp + Univ_steps q' tp'[@Fin0] k'
end.