Section StateWhile.
Variable n : nat.
Variable sig : finType.
Variable F1 F2 : finType.
Variable pM : F1 -> pTM sig (F1 + F2) n.
Definition StateWhile_states : Type := { l : F1 & state (projT1 (pM l)) }.
Definition liftState {l : F1} (q : state (projT1 (pM l))) : StateWhile_states := ltac:(eexists; apply q). (* existT _ l q *)
Definition lift {l : F1} (c : mconfig sig (state (projT1 (pM l))) n) : mconfig sig (FinType(EqType StateWhile_states)) n :=
{|
cstate := liftState (cstate c);
ctapes := ctapes c;
|}.
Definition StateWhile_trans : StateWhile_states * Vector.t (option sig) n -> StateWhile_states * Vector.t (option sig * move) n :=
fun '(q, s) =>
if halt (projT2 q)
then match projT2 (pM (projT1 q)) (projT2 q) with
| inl l1 => (liftState (start (projT1 (pM l1))), nop_action)
| inr _ => (q, nop_action) (* terminating state, transition is irrelevant *)
end
else let (q', a) := trans (projT2 q, s) in (liftState q', a).
Definition StateWhile_halt : StateWhile_states -> bool :=
fun q => halt (projT2 q) &&
match projT2 (pM (projT1 q)) (projT2 q) with
| inl _ => false
| inr l2 => true
end.
Definition StateWhileTM (l1 : F1) : TM sig n :=
{|
start := liftState (start (projT1 (pM l1)));
trans := StateWhile_trans;
halt := StateWhile_halt;
|}.
Hypothesis (defF : inhabitedC F2).
Definition StateWhile_part : StateWhile_states -> F2 :=
fun q => match projT2 (pM (projT1 q)) (projT2 q) with
| inl _ => default
| inr l2 => l2
end.
Definition StateWhile (l1 : F1) : pTM sig F2 n :=
(StateWhileTM l1; StateWhile_part).
Local Arguments loopM {_ _} _ _ _.
Local Arguments halt {_ _} _ _.
Local Arguments step {_ _} _ _.
(* ** Correctness of [StateWhile] *)
Variable R : F1 -> pRel sig (F1 + F2) n.
Inductive StateWhile_Rel : F1 -> pRel sig F2 n :=
| StateWhile_Rel_loop :
forall l t l1 t' l' t'',
R l t (inl l1, t') ->
StateWhile_Rel l1 t' (l', t'') ->
StateWhile_Rel l t (l', t'')
| StateWhile_Rel_break :
forall l t l2 t',
R l t (inr l2, t') ->
StateWhile_Rel l t (l2, t').

Lemma lift_init l tin :
initc (StateWhileTM l) tin = lift (initc (projT1 (pM l)) tin).