(** * Implementation of [ϕ] (aka SplitBody) *)

Require Import TM.Code.ProgrammingTools.
Require Import TM.LM.Semantics TM.LM.Alphabets.
Require Import TM.LM.CaseCom.
Require Import TM.Code.ListTM TM.Code.CaseList TM.Code.CaseNat.

Local Arguments plus : simpl never.
Local Arguments mult : simpl never.

(** The [JumpTarget] machine only operates on programs. Thus we define [JumpTarget] on the alphabet [sigPro^+]. *)

(** This is the only way we can encode [nat] on [sigPro]: as a variable token. *)
Definition retr_nat_prog : Retract sigNat sigPro := Retract_sigList_X _.

(** append a token to the token list *)
Definition App_Comens : pTM sigPro^+ (FinType(EqType unit)) 2 :=
  App' _ @ [|Fin0; Fin1|];;
  MoveValue _ @ [|Fin1; Fin0|].

Definition App_Comens_Rel : pRel sigPro^+ (FinType(EqType unit)) 2 :=
  ignoreParam (
      fun tin tout =>
        forall (Q Q' : list Com),
          tin[@Fin0] ≃ Q ->
          tin[@Fin1] ≃ Q' ->
          tout[@Fin0] ≃ Q ++ Q' /\
          isRight tout[@Fin1]
    ).

Lemma App_Comens_Realise : App_Comens ⊨ App_Comens_Rel.
Proof.
  eapply Realise_monotone.
  { unfold App_Comens. TM_Correct.
    - apply App'_Realise with (X := Com).
    - apply MoveValue_Realise with (X := Pro).
  }
  {
    intros tin ((), tout) H. intros Q Q' HEncQ HEncQ'.
    TMSimp. modpon H. modpon H0. auto.
  }
Qed.

Definition App_Comens_steps (Q Q': Pro) := 1 + App'_steps _ Q + MoveValue_steps _ _ (Q ++ Q') Q.

Definition App_Comens_T : tRel sigPro^+ 2 :=
  fun tin k => exists (Q Q' : list Com), tin[@Fin0] ≃ Q /\ tin[@Fin1] ≃ Q' /\ App_Comens_steps Q Q' <= k.

Lemma App_Comens_Terminates : projT1 App_Comens ↓ App_Comens_T.
Proof.
  eapply TerminatesIn_monotone.
  { unfold App_Comens. TM_Correct.
    - apply App'_Realise with (X := Com).
    - apply App'_Terminates with (X := Com).
    - apply MoveValue_Terminates with (X := Pro) (Y := Pro).
  }
  {
    intros tin k (Q&Q'&HEncQ&HEncQ'&Hk).
    exists (App'_steps _ Q), (MoveValue_steps _ _ (Q++Q') Q); cbn; repeat split; try omega.
    hnf; cbn. eauto. now rewrite Hk.
    intros tmid () (HApp&HInjApp); TMSimp. modpon HApp.
    exists (Q++Q'), Q. repeat split; eauto.
  }
Qed.

(** append a token to the token list *)
Definition App_ACom (t : ACom) : pTM sigPro^+ unit 2 :=
  WriteValue (encode [ACom2Com t]) @ [|Fin1|];;
  App_Comens.

Definition App_ACom_Rel (t : ACom) : pRel sigPro^+ unit 2 :=
  ignoreParam (
      fun tin tout =>
        forall (Q : list Com),
          tin[@Fin0] ≃ Q ->
          isRight tin[@Fin1] ->
          tout[@Fin0] ≃ Q ++ [ACom2Com t] /\
          isRight tout[@Fin1]
    ).

Lemma App_ACom_Realise t : App_ACom t ⊨ App_ACom_Rel t.
Proof.
  eapply Realise_monotone.
  { unfold App_ACom. TM_Correct.
    - apply App_Comens_Realise.
  }
  {
    intros tin ((), tout) H. intros Q HENcQ HRight1.
    TMSimp. specialize (H [ACom2Com t] eq_refl). modpon H. modpon H0. auto.
  }
Qed.

Definition App_ACom_steps (Q: Pro) (t: ACom) := 1 + WriteValue_steps (size _ [ACom2Com t]) + App_Comens_steps Q [ACom2Com t].

Definition App_ACom_T (t: ACom) : tRel sigPro^+ 2 :=
  fun tin k => exists (Q: list Com), tin[@Fin0] ≃ Q /\ isRight tin[@Fin1] /\ App_ACom_steps Q t <= k.

Lemma App_ACom_Terminates (t: ACom) : projT1 (App_ACom t) ↓ App_ACom_T t.
Proof.
  eapply TerminatesIn_monotone.
  { unfold App_ACom. TM_Correct.
    - apply App_Comens_Terminates.
  }
  {
    intros tin k. intros (Q&HEncQ&HRight&Hk).
    exists (WriteValue_steps (size _ [ACom2Com t])), (App_Comens_steps Q [ACom2Com t]). cbn; repeat split; try omega.
    now rewrite Hk.
    intros tmid () (HWrite&HInjWrite); hnf; cbn; TMSimp. specialize (HWrite [ACom2Com t] eq_refl). modpon HWrite. eauto.
  }
Qed.

(** Add a singleton list of tokes to [Q] *)
Definition App_Com : pTM sigPro^+ (FinType(EqType unit)) 3 :=
  Constr_nil _ @ [|Fin2|];;
  Constr_cons _@ [|Fin2; Fin1|];;
  App_Comens @ [|Fin0; Fin2|];;
  Reset _ @ [|Fin1|].

Definition App_Com_Rel : pRel sigPro^+ (FinType(EqType unit)) 3 :=
  ignoreParam (
      fun tin tout =>
        forall (Q : list Com) (t : Com),
          tin[@Fin0] ≃ Q ->
          tin[@Fin1] ≃ t ->
          isRight tin[@Fin2] ->
          tout[@Fin0] ≃ Q ++ [t] /\
          isRight tout[@Fin1] /\
          isRight tout[@Fin2]
    ).

Lemma App_Com_Realise : App_Com ⊨ App_Com_Rel.
Proof.
  eapply Realise_monotone.
  { unfold App_Com. TM_Correct.
    - apply App_Comens_Realise.
    - apply Reset_Realise with (X := Com).
  }
  { intros tin ((), tout) H. cbn. intros Q t HEncQ HEncT HRight.
    unfold sigPro, sigCom in *. TMSimp.
    rename H into HNil, H0 into HCons, H1 into HApp, H2 into HReset.
    modpon HNil. modpon HCons. modpon HApp. modpon HReset. repeat split; auto.
  }
Qed.

Definition App_Com_steps (Q: Pro) (t:Com) :=
  3 + Constr_nil_steps + Constr_cons_steps _ t + App_Comens_steps Q [t] + Reset_steps _ t.

Definition App_Com_T : tRel sigPro^+ 3 :=
  fun tin k => exists (Q: list Com) (t: Com), tin[@Fin0] ≃ Q /\ tin[@Fin1] ≃ t /\ isRight tin[@Fin2] /\ App_Com_steps Q t <= k.

Lemma App_Com_Terminates : projT1 App_Com ↓ App_Com_T.
Proof.
  eapply TerminatesIn_monotone.
  { unfold App_Com. TM_Correct.
    - apply App_Comens_Realise.
    - apply App_Comens_Terminates.
    - apply Reset_Terminates with (X := Com).
  }
  {
    intros tin k (Q&t&HEncQ&HEncT&HRight&Hk). unfold App_Com_steps in Hk.
    exists (Constr_nil_steps), (1 + Constr_cons_steps _ t + 1 + App_Comens_steps Q [t] + Reset_steps _ t). cbn. repeat split; try omega.
    intros tmid () (HNil&HInjNil); TMSimp. modpon HNil.
    exists (Constr_cons_steps _ t), (1 + App_Comens_steps Q [t] + Reset_steps _ t). cbn. repeat split; try omega.
    eauto. now rewrite !Nat.add_assoc.
    unfold sigPro in *. intros tmid0 () (HCons&HInjCons); TMSimp. modpon HCons.
    exists (App_Comens_steps Q [t]), (Reset_steps _ t). cbn. repeat split; try omega.
    hnf; cbn. do 2 eexists; repeat split; eauto. reflexivity.
    intros tmid1 _ (HApp&HInjApp); TMSimp. modpon HApp.
    eexists. split; eauto. now setoid_rewrite Reset_steps_comp.
  }
Qed.

Definition JumpTarget_Step : pTM sigPro^+ (option bool) 5 :=
  If (CaseList sigCom_fin @ [|Fin0; Fin3|])
     (Switch (ChangeAlphabet CaseCom _ @ [|Fin3|])
             (fun t : option ACom =>
                match t with
                | Some retAT =>
                  If (CaseNat ⇑ retr_nat_prog @ [|Fin2|])
                     (Return (App_ACom retAT @ [|Fin1; Fin4|]) None) (* continue *)
                     (Return (ResetEmpty1 _ @ [|Fin2|]) (Some true)) (* return true *)
                | Some lamAT =>
                  Return (Constr_S ⇑ retr_nat_prog @ [|Fin2|];;
                          App_ACom lamAT @ [|Fin1; Fin4|])
                         None (* continue *)
                | Some appAT =>
                  Return (App_ACom appAT @ [|Fin1;Fin4|])
                         None (* continue *)
                | None => (* Variable *)
                  Return (Constr_varT ⇑ _ @ [|Fin3|];;
                          App_Com @ [|Fin1; Fin3; Fin4|])
                         None (* continue *)
                end))
     (Return Nop (Some false)) (* return false *)
.

Definition JumpTarget_Step_Rel : pRel sigPro^+ (option bool) 5 :=
  fun tin '(yout, tout) =>
    forall (P Q : Pro) (k : nat),
      tin[@Fin0] ≃ P ->
      tin[@Fin1] ≃ Q ->
      tin[@Fin2] ≃ k ->
      isRight tin[@Fin3] -> isRight tin[@Fin4] ->
      match yout, P with
      | _, retT :: P =>
        match yout, k with
        | Some true, O => (* return true *)
          tout[@Fin0] ≃ P /\
          tout[@Fin1] ≃ Q /\
          isRight tout[@Fin2]
        | None, S k' => (* continue *)
          tout[@Fin0] ≃ P /\
          tout[@Fin1] ≃ Q ++ [retT] /\
          tout[@Fin2] ≃ k'
        | _, _ => False (* not the case *)
        end
      | None, lamT :: P => (* continue *)
        tout[@Fin0] ≃ P /\
        tout[@Fin1] ≃ Q ++ [lamT] /\
        tout[@Fin2] ≃ S k
      | None, t :: P => (* continue *)
        tout[@Fin0] ≃ P /\
        tout[@Fin1] ≃ Q ++ [t] /\
        tout[@Fin2] ≃ k
      | Some false, nil => (* return false *)
        (*
        tout[@Fin0] ≃ nil /\
        tout[@Fin1] ≃ Q /\
        tout[@Fin2] ≃ k
         *)
        True
      | _, _ => False (* not the case *)
      end /\
      isRight tout[@Fin3] /\
      isRight tout[@Fin4].

Lemma JumpTarget_Step_Realise : JumpTarget_Step ⊨ JumpTarget_Step_Rel.
Proof.
  eapply Realise_monotone.
  { unfold JumpTarget_Step. TM_Correct.
    - eapply RealiseIn_Realise. apply CaseCom_Sem.
    - apply App_ACom_Realise.
    - eapply RealiseIn_Realise. apply ResetEmpty1_Sem with (X := nat).
    - apply App_ACom_Realise.
    - apply App_ACom_Realise.
    - eapply RealiseIn_Realise. apply Constr_varT_Sem.
    - apply App_Com_Realise.
  }
  {
    intros tin (yout, tout) H. cbn. intros P Q k HEncP HEncQ HEncK HInt3 HInt4.
    unfold sigPro in *. rename H into HIf.
    destruct HIf; TMSimp.
    { (* Then of [CaseList], i.e. P = t :: P' *) rename H into HCaseList, H0 into HCaseCom, H1 into HCase.
      modpon HCaseList. destruct P as [ | t P']; auto; modpon HCaseList.
      modpon HCaseCom.
      destruct ymid as [ [ | | ] | ]; try destruct t; auto; simpl_surject; TMSimp.
      { (* t = retT *)
        destruct HCase; TMSimp.
        { (* k = S k' *) rename H into HCaseNat, H0 into HApp.
          modpon HCaseNat. destruct k as [ | k']; auto; modpon HCaseNat.
          modpon HApp.
          repeat split; auto.
        }
        { (* k = 0 *) rename H into HCaseNat. rename H0 into HReset.
          modpon HCaseNat. destruct k as [ | k']; auto; modpon HCaseNat. modpon HReset .
          repeat split; auto.
        }
      }
      { (* t = lamT *) rename H into HS, H0 into HApp.
        modpon HS.
        modpon HApp.
        repeat split; auto.
      }
      { (* t = appT *) rename H into HApp.
        modpon HApp.
        repeat split; auto.
      }
      { (* t = varT *) rename H into HVar, H0 into HApp.
        modpon HVar.
        modpon HApp.
        repeat split; auto.
      }
    }
    { (* Else of [CaseList], i.e. P = nil *)
      modpon H. destruct P; auto; modpon H; auto.
    }
  }
Qed.

(* Steps after the [CaseCom], depending on [t] *)
Local Definition JumpTarget_Step_steps_CaseCom (Q: Pro) (k: nat) (t: Com) :=
  match t with
  | retT =>
    match k with
    | S _ => 1 + CaseNat_steps + App_ACom_steps Q retAT
    | 0 => 2 + CaseNat_steps + ResetEmpty1_steps
    end
  | lamT => 1 + Constr_S_steps + App_ACom_steps Q lamAT
  | appT => App_ACom_steps Q appAT
  | varT n => 1 + Constr_varT_steps + App_Com_steps Q t
  end.

(* Steps after the [CaseList] *)
Local Definition JumpTarget_Step_steps_CaseList (P Q : Pro) (k: nat) :=
  match P with
  | t :: P' => 1 + CaseCom_steps + JumpTarget_Step_steps_CaseCom Q k t
  | nil => 0
  end.

(* Total steps *)
Definition JumpTarget_Step_steps (P Q: Pro) (k: nat) :=
  1 + CaseList_steps _ P + JumpTarget_Step_steps_CaseList P Q k.

Definition JumpTarget_Step_T : tRel sigPro^+ 5 :=
  fun tin steps => (* Warning: I have to use another variable for the steps, since [k] is used. *)
    exists (P Q : Pro) (k : nat),
      tin[@Fin0] ≃ P /\
      tin[@Fin1] ≃ Q /\
      tin[@Fin2] ≃ k /\
      isRight tin[@Fin3] /\ isRight tin[@Fin4] /\
      JumpTarget_Step_steps P Q k <= steps.

Lemma JumpTarget_Step_Terminates : projT1 JumpTarget_Step ↓ JumpTarget_Step_T.
Proof.
  eapply TerminatesIn_monotone.
  { unfold JumpTarget_Step. TM_Correct.
    - eapply RealiseIn_Realise. apply CaseCom_Sem.
    - eapply RealiseIn_TerminatesIn. apply CaseCom_Sem.
    - apply App_ACom_Terminates.
    - eapply RealiseIn_TerminatesIn. apply ResetEmpty1_Sem with (X := nat).
    - apply App_ACom_Terminates.
    - apply App_ACom_Terminates.
    - eapply RealiseIn_Realise. apply Constr_varT_Sem.
    - eapply RealiseIn_TerminatesIn. apply Constr_varT_Sem.
    - apply App_Com_Terminates.
  }
  {
    intros tin steps (P&Q&k&HEncP&HEncQ&HEncK&HRight3&HRight4&Hk). unfold JumpTarget_Step_steps in Hk. cbn in *.
    unfold sigPro in *.
    exists (CaseList_steps _ P), (JumpTarget_Step_steps_CaseList P Q k). cbn; repeat split; try omega. eauto.
    intros tmid bmatchlist (HCaseList&HCaseListInj); TMSimp. modpon HCaseList.
    destruct bmatchlist, P as [ | t P']; auto; modpon HCaseList.
    { (* P = t :: P' (* other case is done by auto *) *)
      exists (CaseCom_steps), (JumpTarget_Step_steps_CaseCom Q k t). cbn; repeat split; try omega.
      intros tmid1 ytok (HCaseCom&HCaseComInj); TMSimp. modpon HCaseCom.
      destruct ytok as [ [ | | ] | ]; destruct t; auto; simpl_surject; TMSimp.
      { (* t = retT *)
        exists CaseNat_steps.
        destruct k as [ | k'].
        - (* k = 0 *)
          exists ResetEmpty1_steps. repeat split; try omega.
          intros tmid2 bCaseNat (HCaseNat&HCaseNatInj); TMSimp. modpon HCaseNat. destruct bCaseNat; auto.
        - (* k = S k' *)
          exists (App_ACom_steps Q retAT). repeat split; try omega.
          intros tmid2 bCaseNat (HCaseNat&HCaseNatInj); TMSimp. modpon HCaseNat. destruct bCaseNat; auto. hnf; cbn. eauto.
      }
      { (* t = lamT *)
        exists (Constr_S_steps), (App_ACom_steps Q lamAT). repeat split; try omega.
        intros tmid2 () (HS&HSInj); TMSimp. modpon HS. hnf; cbn. eauto.
      }
      { (* t = appT *) hnf; cbn; eauto. }
      { (* t = varT n *)
        exists (Constr_varT_steps), (App_Com_steps Q (varT n)). repeat split; try omega.
        intros tmid2 H (HVarT&HVarTInj); TMSimp. modpon HVarT. hnf; cbn. eauto 6.
      }
    }
  }
Qed.

Fixpoint jumpTarget_k (k:nat) (P:Pro) : nat :=
  match P with
  | retT :: P' => match k with
                 | 0 => 0
                 | S k' => jumpTarget_k k' P'
                 end
  | lamT :: P' => jumpTarget_k (S k) P'
  | t :: P'    => jumpTarget_k k P' (* either [varT n] or [appT] *)
  | []         => k
  end.

Goal forall k P, jumpTarget_k k P <= k + |P|.
Proof.
  intros k P. revert k. induction P as [ | t P IH]; intros; cbn in *.
  - omega.
  - destruct t; cbn.
    + rewrite IH. omega.
    + rewrite IH. omega.
    + rewrite IH. omega.
    + destruct k. omega. rewrite IH. omega.
Qed.

Definition JumpTarget_Loop := While JumpTarget_Step.

Definition JumpTarget_Loop_Rel : pRel sigPro^+ bool 5 :=
  fun tin '(yout, tout) =>
    forall (P Q : Pro) (k : nat),
      tin[@Fin0] ≃ P ->
      tin[@Fin1] ≃ Q ->
      tin[@Fin2] ≃ k ->
      isRight tin[@Fin3] -> isRight tin[@Fin4] ->
      match yout with
      | true =>
        exists (P' Q' : Pro),
        jumpTarget k Q P = Some (Q', P') /\
        tout[@Fin0] ≃ P' /\
        tout[@Fin1] ≃ Q' /\
        isRight tout[@Fin2] /\
        isRight tout[@Fin3] /\ isRight tout[@Fin4]
      | false =>
        jumpTarget k Q P = None
      end.

Lemma JumpTarget_Loop_Realise : JumpTarget_Loop ⊨ JumpTarget_Loop_Rel.
Proof.
  eapply Realise_monotone.
  { unfold JumpTarget_Loop. TM_Correct.
    - apply JumpTarget_Step_Realise.
  }
  {
    apply WhileInduction; intros; intros P Q k HEncP HEncQ HEncK HRight3 HRight4; cbn in *.
    {
      modpon HLastStep. destruct yout, P as [ | [ | | | ] P']; auto. destruct k; auto. modpon HLastStep.
      cbn. eauto 10.
    }
    {
      modpon HStar.
      destruct P as [ | [ | | | ] P']; auto; modpon HStar.
      - (* P = varT n :: P' *) modpon HLastStep. destruct yout; auto.
      - (* P = appT :: P' *) modpon HLastStep. destruct yout; auto.
      - (* P = lamT :: P' *) modpon HLastStep. destruct yout; auto.
      - (* P = varT k :: P', k = S k' *) destruct k as [ | k']; auto; modpon HStar. modpon HLastStep. destruct yout; auto.
    }
  }
Qed.

Fixpoint JumpTarget_Loop_steps (P Q: Pro) (k: nat) : nat :=
  match P with
  | nil => JumpTarget_Step_steps P Q k
  | t :: P' =>
    match t with
    | retT =>
      match k with
      | S k' => 1 + JumpTarget_Step_steps P Q k + JumpTarget_Loop_steps P' (Q++[t]) k'
      | 0 =>        JumpTarget_Step_steps P Q k (* terminal case *)
      end
    | lamT =>   1 + JumpTarget_Step_steps P Q k + JumpTarget_Loop_steps P' (Q++[t]) (S k)
    | appT =>   1 + JumpTarget_Step_steps P Q k + JumpTarget_Loop_steps P' (Q++[t]) k
    | varT n => 1 + JumpTarget_Step_steps P Q k + JumpTarget_Loop_steps P' (Q++[t]) k
    end
  end.

Definition JumpTarget_Loop_T : tRel sigPro^+ 5 :=
  fun tin steps =>
    exists (P Q : Pro) (k : nat),
      tin[@Fin0] ≃ P /\
      tin[@Fin1] ≃ Q /\
      tin[@Fin2] ≃ k /\
      isRight tin[@Fin3] /\ isRight tin[@Fin4] /\
      JumpTarget_Loop_steps P Q k <= steps.

Lemma JumpTarget_Loop_Terminates : projT1 JumpTarget_Loop ↓ JumpTarget_Loop_T.
Proof.
  eapply TerminatesIn_monotone.
  { unfold JumpTarget_Loop. TM_Correct.
    - apply JumpTarget_Step_Realise.
    - apply JumpTarget_Step_Terminates. }
  {
    apply WhileCoInduction. intros tin steps. intros (P&Q&k&HEncP&HEncQ&HEncK&HRight3&HRight4&Hk).
    exists (JumpTarget_Step_steps P Q k). repeat split. hnf; cbn; eauto 10.
    intros ymid tmid HStep. cbn in HStep. modpon HStep. destruct ymid as [ [ | ] | ].
    { (* [Some true], i.e. [P = retT :: P'] and [k = 0] *)
      destruct P as [ | [ | | | ] ]; auto. destruct k; auto.
    }
    { (* [Some false], i.e. [P = nil] *)
      destruct P as [ | [ | | | ] ]; auto.
    }
    { (* recursion cases *)
      destruct P as [ | t P ]; auto.
      destruct t; modpon HStep.
      - (* t = varT n *)
        exists (JumpTarget_Loop_steps P (Q++[varT n]) k). split.
        + hnf. do 3 eexists; repeat split; eauto.
        + assumption.
      - (* t = appT *)
        exists (JumpTarget_Loop_steps P (Q++[appT]) k). split.
        + hnf. do 3 eexists; repeat split; eauto.
        + assumption.
      - (* t = lamT *)
        exists (JumpTarget_Loop_steps P (Q++[lamT]) (S k)). split.
        + hnf. do 3 eexists; repeat split; eauto.
        + assumption.
      - (* t = retT, k = S k' *)
        destruct k as [ | k']; auto; modpon HStep.
        exists (JumpTarget_Loop_steps P (Q++[retT]) k'). split.
        + hnf. do 3 eexists; repeat split; eauto.
        + assumption.
    }
  }
Qed.

Definition JumpTarget : pTM sigPro^+ bool 5 :=
  Constr_nil _ @ [|Fin1|];;
  Constr_O ⇑ _ @ [|Fin2|];;
  JumpTarget_Loop.

Definition JumpTarget_Rel : pRel sigPro^+ bool 5 :=
  fun tin '(yout, tout) =>
    forall (P : Pro),
      tin[@Fin0] ≃ P ->
      isRight tin[@Fin1] ->
      (forall i : Fin.t 3, isRight tin[@FinR 2 i : Fin.t 5]) ->
      match yout with
      | true =>
        exists (P' Q' : Pro),
        jumpTarget 0 nil P = Some (Q', P') /\
        tout[@Fin0] ≃ P' /\
        tout[@Fin1] ≃ Q' /\
        (forall i : Fin.t 3, isRight tout[@FinR 2 i : Fin.t 5])
      | false =>
        jumpTarget 0 nil P = None
      end.

Lemma JumpTarget_Realise : JumpTarget ⊨ JumpTarget_Rel.
Proof.
  eapply Realise_monotone.
  { unfold JumpTarget. TM_Correct.
    - apply JumpTarget_Loop_Realise.
  }
  {
    intros tin (yout, tout) H. cbn. intros P HEncP HOut HInt.
    TMSimp ( unfold sigPro, sigCom in * ). rename H into HWriteNil, H0 into HWriteO, H1 into HLoop.
    modpon HWriteNil. modpon HWriteO. modpon HLoop.
    destruct yout.
    - destruct HLoop as (P'&Q'&HLoop); modpon HLoop. do 2 eexists; repeat split; eauto.
      intros i; destruct_fin i; TMSimp_goal; auto.
    - eauto.
  }
Qed.

Definition JumpTarget_steps (P : Pro) :=
  3 + Constr_nil_steps + Constr_O_steps + JumpTarget_Loop_steps P nil 0.

Definition JumpTarget_T : tRel sigPro^+ 5 :=
  fun tin k =>
    exists (P : Pro),
      tin[@Fin0] ≃ P /\
      isRight tin[@Fin1] /\
      (forall i : Fin.t 3, isRight tin[@Fin.R 2 i]) /\
      JumpTarget_steps P <= k.

Lemma JumpTarget_Terminates : projT1 JumpTarget ↓ JumpTarget_T.
Proof.
  eapply TerminatesIn_monotone.
  { unfold JumpTarget. TM_Correct.
    - apply JumpTarget_Loop_Terminates.
  }
  {
    intros tin k (P&HEncP&Hout&HInt&Hk). unfold JumpTarget_steps in Hk.
    exists (Constr_nil_steps), (1 + Constr_O_steps + 1 + JumpTarget_Loop_steps P nil 0).
    cbn; repeat split; try omega.
    intros tmid () (HWrite&HWriteInj); TMSimp. modpon HWrite.
    exists (Constr_O_steps), (1 + JumpTarget_Loop_steps P nil 0).
    cbn; repeat split; try omega.
    cbn in *. unfold sigPro in *. intros tmid1 () (HWrite'&HWriteInj'); TMSimp. modpon HWrite'.
    hnf. do 3 eexists; repeat split; cbn in *; unfold sigPro in *; cbn in *; TMSimp_goal; eauto.
  }
Qed.


From TLC Require Import LibLN.
Require Import DeclDef DeclInfra DeclProp.
Require Import Translation.
Require Import PBCDef PBCInfra PBCProp.
Require Import DeclTyping DeclSub DeclEnvSub.
Require Import OLDef.

(** * Conservative Extension *)

Hint Constructors dtyping otyping.
Hint Resolve denv_static_dokt otyping_regular.

Lemma conservative_extension: forall E e T,
    denv_static E ->
    dterm_static e ->
    dtyp_static T ->
    otyping E e T ->
    exists A, dtyping E e A /\ dsub E A T.
Proof.
  introv Hen Htm Htyp.

  introv Ht.
  inductions Ht; autos ~;
     try(solve[exists~ T; splits~]).

  exists ~ T. splits~. apply~ dsub_refl.
  apply* dwft_from_env_has_typ.

  exists ~ (dtyp_nat).

  pick_fresh y.
  forwards ~ : H1 y.
  constructor~. inversions~ Htyp.
  forwards ~ : H0 y.
  lets ~ [? [? ?]]: otyping_regular H2.
  apply denv_static_dokt in H3.
  apply* dokt_push_typ_inv.
  forwards ~ : H0 y.
  lets ~ [? [? ?]]: otyping_regular H2.
  forwards ~ : H0 y.
  lets ~ [? [? [? ?]]]: otyping_regular H2.
  destruct H2 as (C & [? ?]).
  apply dtyping_dtyping' in H2.
  assert (dtyping' E (dtrm_absann A e) (dtyp_arrow A C)).
  apply dtyping'_absann with y; auto.
  lets [_ [? _]]: dsub_regular H3.
  assert (dwft E C).
  apply_empty~ dwft_strengthen_typ.
  assert (y \notin dfv_tt C).
  apply (dwft_notin_env H6); auto.
  auto.
  lets ~ : dtyping'_dtyping H4.
  exists ~ (dtyp_arrow A C). splits~. constructor~.
  apply* dsub_refl.
  apply_empty* dsub_strengthen_typ.

  pick_fresh y.
  forwards ~ : H1 y.
  constructor~. inversions~ Htyp.
  forwards ~ : H0 y.
  lets ~ [? [? ?]]: otyping_regular H2.
  apply denv_static_dokt in H3.
  apply* dokt_push_typ_inv.
  forwards ~ : H0 y.
  lets ~ [? [? ?]]: otyping_regular H2.
  forwards ~ : H0 y.
  lets ~ [? [? [? ?]]]: otyping_regular H2.
  destruct H2 as (C & [? ?]).
  apply dtyping_dtyping' in H2.
  assert (dtyping' E (dtrm_abs e) (dtyp_arrow A C)).
  apply dtyping'_abs with y; auto.
  lets [_ [? _]]: dsub_regular H3.
  assert (dwft E C).
  apply_empty~ dwft_strengthen_typ.
  assert (y \notin dfv_tt C).
  apply (dwft_notin_env H6); auto.
  auto.
  lets ~ : dtyping'_dtyping H4.
  exists ~ (dtyp_arrow A C). splits~. constructor~.
  apply* dsub_refl.
  apply_empty* dsub_strengthen_typ.

  forwards ~ (B1 & [? ?]) : IHHt1.
    lets~ [? [? [? ?]]] : otyping_regular Ht1.
    lets~ [? [? [? ?]]] : otyping_regular Ht1.
  forwards ~ (B2 & [? ?]) : IHHt2.
    lets~ [? [? [? ?]]] : otyping_regular Ht2.
    lets~ [? [? [? ?]]] : otyping_regular Ht2.
  forwards ~ (C1 & C2 & [? ?]): dsub_match_arrow H0.
  inversions H4.
  exists ~ C2. splits~.
  apply* dtyping_app.
  apply dsub_consub.
  apply dsub_trans with A1; auto.

  forwards ~ (A0 & [? ?]) : IHHt.
  lets~ [? [? [? ?]]] : otyping_regular Ht.
  exists ~ A0. splits~.
  apply dsub_trans with A; auto.

  inversions Htyp.
  pick_fresh y.
  forwards ~ : H0 y.
  destruct H1 as (C & [? ?]).
  apply dtyping_dtyping' in H1.
  assert (dtyping' E e (dtyp_all (dclose_tt y C))).
  apply dtyping'_gen with y; auto.
  assert (y \notin dfv_tt (dclose_tt y C)).
    apply dclose_tt_fresh.
  auto.
  rewrite~ <- dclose_tt_open_var.
  lets~ [_ [? _]]: dsub_regular H3.
  exists ~ (dtyp_all (dclose_tt y C)).
  splits~.
  apply* dtyping'_dtyping.
  apply dsub'_dsub.
  apply dsub'_allR with y; auto.
  assert (y \notin dfv_tt (dtyp_all (dclose_tt y C))).
  simpls. apply dclose_tt_fresh.
  auto.
  apply dsub'_allL with (dtyp_fvar y); auto.
  rewrite~ <- dclose_tt_open_var.
  apply~ dsub_dsub'.
  lets~ [? [? _]]: dsub_regular H3.

  inversions Htm.
  apply otyping_regular in Ht. destructs Ht.
  forwards ~ : IHHt. destruct H7 as (A0 & [I1 I2]).
  pick_fresh y.
  forwards ~ (C & [? ?]) : H0 y. clear H0 IHHt.
  assert (I3 : dsub (E & y ~: A) A0 A).
    apply~ dsub_push.
  lets ~ (T & [? ?]) : dtyping_bind_strengthen H7 I3.
  exists T. splits~.
  apply dtyping'_dtyping.
  apply dtyping'_let with y A0; auto.
  apply~ dtyping_dtyping'.
  apply~ dtyping_dtyping'.
  apply dsub_strengthen_typ_push in H9.
  apply dsub_strengthen_typ_push in H8.
  lets~ : dsub_trans H9 H8.
Qed.

Lemma conserv_extension_b: forall E e T,
    denv_static E ->
    dterm_static e ->
    dtyp_static T ->
    dtyping E e T ->
    otyping E e T.
Proof.
  introv Hen Htm Htyp.

  introv Ht.
  inductions Ht; autos ~.

  inversions Htyp.
  inversions Htm.
  apply_fresh otyping_absann as x; auto.
  apply~ H1.
  apply~ denv_static_typ.
  forwards ~ : H0 x.
  lets ~ [? [_ _]]: dtyping_regular H2.
  apply dokt_push_typ_inv in H3. auto.

  inversions~ Htm.
  forwards ~ : IHHt1.
  apply* dtyping_static_preserve.
  forwards ~ : IHHt2.
  apply* dtyping_static_preserve.
  apply* otyping_app.
  apply otyping_sub with A; auto.
  apply dsub_trans with (dtyp_arrow A1 A2); auto.
  apply~ dmatch_static_sub.
  apply* dtyping_static_preserve.
  constructor~.
  apply~ dconsub_static_sub.
  apply* dtyping_static_preserve.
  lets ~ [? ?] : dmatch_static_preserve H.
  apply* dtyping_static_preserve.
  apply~ dsub_refl.
  lets~ [? ?] : dmatch_regular H.

  inversions Htyp.
  inversions Htm.
  apply_fresh otyping_abs as x; auto.
  apply~ H1.
  constructor~.
  forwards ~ : H0 x.
  lets ~ [? [_ _]]: dtyping_regular H2.
  apply dokt_push_typ_inv in H6. auto.

  inversions Htyp.
  apply_fresh otyping_gen as x; auto.

  inversions Htm.
  apply_fresh otyping_let as x; auto.
  apply~ IHHt.
  apply* dtyping_static_preserve.
  apply~ H0.
  constructor~.
  apply* dtyping_static_preserve.
Qed.

(** * Monotonicity w.r.t. precision *)

Lemma monotonicity_precision': forall E F e s A,
    dtyping E e A ->
    denv_less_precise F E ->
    dterm_less_precise s e ->
    exists B, dtyping' F s B /\ dtyp_less_precise B A.
Proof.
  introv ty. gen F s.
  inductions ty; introv less_env less_tm.

  (* var *)
  inversions less_tm.
  forwards ~ (B & [? ?]) : denv_less_precise_binds H0 less_env.
  exists B. splits~.
  constructor~.
  apply* denv_less_precise_dokt_l.

  (* nat *)
  inversions less_tm.
  exists ~ dtyp_nat. splits~. constructor~. apply* denv_less_precise_dokt_l.

  (* absann *)
  inversions~ less_tm.
  pick_fresh y.
  assert (I1: denv_less_precise (F & y ~: A1) (E & y ~: A)). constructor~.
    apply dwft_denv_less_precise with E; auto.
    apply dwft_dtyp_less_precise with A; auto.
    forwards ~ : H0 y.
    lets ~ [? _] : dtyping_regular H2.
    apply* dokt_push_typ_inv.
    forwards ~ : H0 y.
    lets ~ [? _] : dtyping_regular H2.
    apply* dokt_push_typ_inv.
  assert (I2: dterm_less_precise (e1 dopen_ee_var y) (e dopen_ee_var y)). auto.
  forwards ~ (C & [? ?]) : H1 I1 I2.
  exists (dtyp_arrow A1 C). split~.
  apply dtyping'_absann with y; auto.
  apply dwft_dtyp_less_precise with A; auto.

  (* app *)
  inversions less_tm.
  forwards ~ (B & [? ?]): IHty1 less_env H4. clear IHty1.
  forwards ~ (C & [? ?]): IHty2 less_env H5. clear IHty2.
  forwards ~ (B1 & B2 & [? [? ?]]) : dmatch_less_precise_input H H2.
  exists ~ B2. splits~.
  apply dtyping'_app with (A:= B) (A1:= B1) (A3:=C); auto.
  lets ~ : dmatch_denv_less_precise H7 less_env.
  lets ~ : dconsub_dtyp_less_precise H0 H6 H8.
  lets ~ : dconsub_denv_less_precise H10 less_env.

  (* abs *)
  inversions~ less_tm.
  pick_fresh y.
  assert (I1: denv_less_precise (F & y ~: A) (E & y ~: A)). constructor~.
    apply dtyp_less_precise_refl.
    apply~ dtyp_mono_dtype.
    apply dwft_denv_less_precise with E; auto.
    forwards ~ : H0 y.
    lets ~ [? _] : dtyping_regular H2.
    apply* dokt_push_typ_inv.
    forwards ~ : H0 y.
    lets ~ [? _] : dtyping_regular H2.
    apply* dokt_push_typ_inv.
  assert (I2: dterm_less_precise (e1 dopen_ee_var y) (e dopen_ee_var y)). auto.
  forwards ~ (C & [? ?]) : H1 I1 I2.
  exists (dtyp_arrow A C). split~.
  apply dtyping'_abs with y; auto.
  assert (dwft F C).
    lets : dtyping'_dtyping H2.
    lets [_ [_ ?]] : dtyping_regular H5.
    apply_empty* dwft_strengthen_typ.
  assert (y \notin dfv_tt C).
    apply (dwft_notin_env H5); auto.
  auto.
  constructor~.
    apply dtyp_less_precise_refl.
    apply~ dtyp_mono_dtype.

  (* gen *)
  pick_fresh y.
  assert (I1: denv_less_precise (F & y ~tvar ) (E & y ~tvar)). constructor~.
  forwards ~ (C & [? ?]) : H0 I1 less_tm.
  exists (dtyp_all (dclose_tt y C)). split~.
  apply dtyping'_gen with y; auto.
  assert (y \notin dfv_tt (dclose_tt y C)).
    apply dclose_tt_fresh; auto.
  auto.
  rewrite~ <- dclose_tt_open_var.
    lets : dtyping'_dtyping H1.
    lets [_ [_ ?]] : dtyping_regular H4.
    auto.
    apply dtyp_less_precise'_precise.
    apply dtyp_less_precise'_all with y.
      assert (y \notin dfv_tt (dclose_tt y C)).
        apply dclose_tt_fresh; auto.
      auto.
  rewrite~ <- dclose_tt_open_var.
  apply~ dtyp_less_precise_precise'.
    lets : dtyping'_dtyping H1.
    lets [_ [_ ?]] : dtyping_regular H3.
    auto.

  (* let *)
  inversions~ less_tm.
  pick_fresh y.
  forwards ~ (D & [I1 I2]) : IHty less_env H4.
  assert (I3: denv_less_precise (F & y ~: D) (E & y ~: A)) by constructor~.
  assert (I4: dterm_less_precise (e4 dopen_ee_var y) (e2 dopen_ee_var y))
         by auto.
  forwards ~ (C & [? ?]) : H0 I3 I4.
  clear H0 IHty.
  exists C. split~.
  apply dtyping'_let with y D; auto.
Qed.

Lemma monotonicity_precision: forall E F e s A,
    dtyping E e A ->
    denv_less_precise F E ->
    dterm_less_precise s e ->
    exists B, dtyping F s B /\ dtyp_less_precise B A.
Proof.
  intros.
  forwards ~ (B & [? ?]): monotonicity_precision' H H0 H1.
  exists~ B. splits~.
  apply* dtyping'_dtyping.
Qed.

(** * Monotonicity of cast insertion *)

Lemma monotonicity_cast_insertion': forall E F e1 e2 s1 A,
    d2ptyping E e1 A s1 ->
    denv_less_precise F E ->
    dterm_less_precise e2 e1 ->
    exists s2 B, d2ptyping' F e2 B s2 /\
    dtyp_less_precise' B A /\
    pterm_less_precise s2 s1.
Proof.
  introv ty1. gen F e2.
  inductions ty1; introv less_env less_tm.

  (* var *)
  forwards ~ (C & [? ?]) : denv_less_precise_binds H0 less_env.
  inversions less_tm.
  exists (ptrm_fvar x) C. splits~.
  constructor~.
  lets~ : denv_less_precise_dokt_l less_env.
  apply* dtyp_less_precise_precise'.
  apply* pterm_less_precise_var.
  lets~ : denv_less_precise_dokt_l less_env.

  (* nat *)
  inversions less_tm.
  exists (ptrm_nat i) dtyp_nat. splits~.
  constructor~.

  (* absann *)
  inversions~ less_tm.
  pick_fresh y.
  forwards~ : H6 y. clear H6.
  forwards~ (s2 & B0 & [? [? ?]]): H1 y (F & y ~: A1) H2.
  constructor~.
  apply dwft_denv_less_precise with E; auto.
  apply dwft_dtyp_less_precise with A; auto.
  forwards~ : H0 y.
  lets~ [? [? ?]]: d2ptyping_regular H3.
  apply* dokt_push_typ_inv.
  forwards~ : H0 y.
  lets~ [? [? ?]]: d2ptyping_regular H3.
  apply* dokt_push_typ_inv.
  exists ~ (ptrm_absann A1 (pclose_ee y s2)) (dtyp_arrow A1 B0).
  splits~.
  apply d2ptyping'_absann with y; auto.
  apply dwft_dtyp_less_precise with A; auto.
  assert (y \notin pfv_ee (pclose_ee y s2)).
    apply pclose_ee_fresh.
  auto.
  rewrite~ <- pclose_ee_open.
  lets ~ : d2ptyping'_d2ptyping H3.
  lets ~ : d2ptyping_term H7.
  constructor~.
  apply~ dtyp_less_precise_precise'.
  apply pterm_less_precise_absann with y; auto.
  assert (y \notin pfv_ee (pclose_ee y s2)).
    apply pclose_ee_fresh.
  auto.
  rewrite~ <- pclose_ee_open.
  lets ~ : d2ptyping'_d2ptyping H3.
  lets ~ : d2ptyping_term H7.

  (* app *)
  inversions less_tm.
  forwards ~ (s3 & C1 & [? [? ?]]) : IHty1_1 less_env H4.
  forwards ~ (s4 & C2 & [? [? ?]]) : IHty1_2 less_env H5.
  clear IHty1_1 IHty1_2.
  lets : dtyp_less_precise'_precise H2.
  forwards ~ (D1 & D2 & [? [? ?]]) : dmatch_less_precise_input H H9.
  lets : dmatch_denv_less_precise H10 less_env. clear H10.
  exists~ (ptrm_app (ptrm_cast C1 (dtyp_arrow D1 D2) s3)
               (ptrm_cast C2 D1 s4))
   D2.
  splits~.
  apply~ d2ptyping'_app.
  lets I1 : dtyp_less_precise'_precise H7.
  lets~ : dconsub_dtyp_less_precise H0 I1 H11.
  lets~ : dconsub_denv_less_precise H10 less_env.
  apply* dtyp_less_precise_precise'.
  apply~ pterm_less_precise_app.
  apply~ pterm_less_precise_cast.
  apply~ pterm_less_precise_cast.
  apply* dtyp_less_precise'_precise.

  (* abs *)
  inversions~ less_tm.
  pick_fresh y.
  forwards~ : H4 y. clear H4.
  forwards~ (s2 & B0 & [? [? ?]]): H1 y (F & y ~: A) H2.
  constructor~.
  apply~ dtyp_less_precise_refl.
    forwards~ : H0 y.
    lets~ [? [? ?]]: d2ptyping_regular H3.
    apply dokt_push_typ_inv in H4. auto.
  apply dwft_denv_less_precise with E; auto.
  forwards~ : H0 y.
  lets~ [? [? ?]]: d2ptyping_regular H3.
  apply* dokt_push_typ_inv.
  forwards~ : H0 y.
  lets~ [? [? ?]]: d2ptyping_regular H3.
  apply* dokt_push_typ_inv.
  exists ~ (ptrm_absann A (pclose_ee y s2)) (dtyp_arrow A B0).
  splits~.
  apply d2ptyping'_abs with y; auto.
  assert (y \notin pfv_ee (pclose_ee y s2)).
    apply pclose_ee_fresh.
  auto.
  rewrite~ <- pclose_ee_open.
  lets ~ : d2ptyping'_d2ptyping H3.
  lets ~ : d2ptyping_term H6.
  constructor~.
  apply~ dtyp_less_precise'_refl.
    forwards~ : H0 y.
    lets~ [? [? ?]]: d2ptyping_regular H6.
    apply dokt_push_typ_inv in H7. auto.
  apply pterm_less_precise_absann with y; auto.
  assert (y \notin pfv_ee (pclose_ee y s2)).
    apply pclose_ee_fresh.
  auto.
  apply* dtyp_less_precise'_precise.
  rewrite~ <- pclose_ee_open.
  lets ~ : d2ptyping'_d2ptyping H3.
  lets ~ : d2ptyping_term H6.

  (* all *)
  pick_fresh y.
  forwards~ : H y. clear H.
  forwards~ (s2 & B0 & [? [? ?]]): H0 y (F & y ~tvar) less_tm.
  constructor~.
  exists ~ (ptrm_tabs (pclose_te y s2)) (dtyp_all (dclose_tt y B0)).
  splits~.
  apply d2ptyping'_gen with y; auto.
  assert (y \notin dfv_tt (dclose_tt y B0)).
    apply dclose_tt_fresh.
  assert (y \notin pfv_te (pclose_te y s2)).
    apply pclose_te_fresh.
  auto.
  rewrite~ <- dclose_tt_open_var.
  rewrite~ <- pclose_te_open.
  lets ~ : d2ptyping'_d2ptyping H.
  lets ~ : d2ptyping_term H4.
  lets ~ : d2ptyping'_d2ptyping H.
  lets ~ [_ [_ ?]]: d2ptyping_regular H4.
  apply dtyp_less_precise'_all with y.
    assert (y \notin dfv_tt (dclose_tt y B0)).
      apply dclose_tt_fresh.
    auto.
  rewrite~ <- dclose_tt_open_var.
    lets ~ : d2ptyping'_d2ptyping H.
    lets ~ [_ [_ ?]]: d2ptyping_regular H4.
  apply pterm_less_precise_tabs with y.
  assert (y \notin pfv_te (pclose_te y s2)).
    apply pclose_te_fresh.
  auto.
  rewrite~ <- pclose_te_open.
  lets ~ : d2ptyping'_d2ptyping H.
  lets ~ : d2ptyping_term H4.

  (* let *)
  inversions~ less_tm.
  pick_fresh y.
  forwards~ : H5 y. clear H5.
  forwards ~ (s4 & C0 & [I1 [I2 I3]]) : IHty1 less_env H4.
  forwards~ (s3 & B0 & [I4 [I5 I6]]): H0 y (F & y ~: C0) H1.
  constructor~.
  apply~ dtyp_less_precise'_precise.
  clear IHty1 H0.
  exists (ptrm_app (ptrm_absann C0 (pclose_ee y s3)) (s4)) B0.
  splits~.
  apply d2ptyping'_let with y; auto.
  assert (y \notin pfv_ee (pclose_ee y s3)).
    apply pclose_ee_fresh.
  auto.
  rewrite~ <- pclose_ee_open.
  lets ~ : d2ptyping'_regular I4. destructs~ H0.
  apply~ pterm_less_precise_app.
  apply pterm_less_precise_absann with y; auto.
  assert (y \notin pfv_ee (pclose_ee y s3)).
    apply pclose_ee_fresh.
  assert (y \notin dfv_tt C0).
    apply dwft_notin_env with F; auto.
  auto.
  apply~ dtyp_less_precise'_precise.
  rewrite~ <- pclose_ee_open.
  lets ~ : d2ptyping'_regular I4. destructs~ H0.
Qed.

Lemma monotonicity_cast_insertion: forall E F e1 e2 s1 A,
    d2ptyping E e1 A s1 ->
    denv_less_precise F E ->
    dterm_less_precise e2 e1 ->
    exists s2 B, d2ptyping F e2 B s2 /\
    dtyp_less_precise B A /\
    pterm_less_precise s2 s1.
Proof.
  introv H1 H2 H3.
  forwards ~ (s2 & B & [? [? ?]]): monotonicity_cast_insertion' H1 H2 H3.
  exists ~ s2 B.
  splits~.
  apply* d2ptyping'_d2ptyping.
  apply* dtyp_less_precise'_precise.
Qed.


Axiom iter2 : bool -> bool -> bool.
Fixpoint do2 (n : nat) (A : bool) :=
  match n with
    | 0 => A
    | S n' => do2 n' (iter2 A A)
  end.
Ltac display2 := match goal with |- let n := ?k in _ => idtac "[2][" k "] :=" end; hnf; unfold do2; cbv beta.
Axiom x : bool.
Notation hidden := (_ = _).
Goal let n := 20 in do2 n x = do2 n x. display2. Time (match goal with |- ?f ?x = ?g ?y => idtac end). (* 2.6 s *) Admitted.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Mem.
Require list.Append.

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Mem.
Require list.Append.

(* Why3 goal *)
Lemma reverse_def : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  ((Lists.List.rev l) = match l with
  | Init.Datatypes.nil => Init.Datatypes.nil
  | (Init.Datatypes.cons x r) =>
      (Init.Datatypes.app (Lists.List.rev r) (Init.Datatypes.cons x Init.Datatypes.nil))
  end).
Proof.
now intros a a_WT [|x l].
Qed.

(* Why3 goal *)
Lemma reverse_append : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (x:a),
  ((Init.Datatypes.app (Lists.List.rev (Init.Datatypes.cons x l1)) l2) = (Init.Datatypes.app (Lists.List.rev l1) (Init.Datatypes.cons x l2))).
Proof.
intros a a_WT l1 l2 x.
simpl.
now rewrite <- List.app_assoc.
Qed.

(* Why3 goal *)
Lemma reverse_cons : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a))
  (x:a),
  ((Lists.List.rev (Init.Datatypes.cons x l)) = (Init.Datatypes.app (Lists.List.rev l) (Init.Datatypes.cons x Init.Datatypes.nil))).
intros a a_WT l x.
simpl.
auto.
Qed.

(* Why3 goal *)
Lemma cons_reverse : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a))
  (x:a),
  ((Init.Datatypes.cons x (Lists.List.rev l)) = (Lists.List.rev (Init.Datatypes.app l (Init.Datatypes.cons x Init.Datatypes.nil)))).
intros a a_WT l x.
now rewrite List.rev_unit.
Qed.

(* Why3 goal *)
Lemma reverse_reverse : forall {a:Type} {a_WT:WhyType a},
  forall (l:(list a)), ((Lists.List.rev (Lists.List.rev l)) = l).
Proof.
intros a a_WT l.
apply List.rev_involutive.
Qed.

(* Why3 goal *)
Lemma reverse_mem : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a))
  (x:a), (list.Mem.mem x l) <-> (list.Mem.mem x (Lists.List.rev l)).
intros a a_WT l x.
induction l; simpl; intuition.
rewrite Append.mem_append.
right; simpl; now intuition.
rewrite Append.mem_append.
now auto.
assert (Mem.mem x (List.rev l) \/ Mem.mem x (a0 :: nil))%list.
rewrite <- Append.mem_append; assumption.
intuition; simpl in *.
intuition.
Qed.

(* Why3 goal *)
Lemma Reverse_length : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  ((list.Length.length (Lists.List.rev l)) = (list.Length.length l)).
Proof.
intros a a_WT l.
rewrite 2!Length.length_std.
now rewrite List.rev_length.
Qed.


Module CoStack.
	CoInductive stack (t : Type) :=
		  Empty
		| Push (top : t) (pop : stack t).

	Definition isEmpty {t: Type} (__input : stack t) : Prop :=
		match __input with
			  Empty  => True
			| _ => False
		end.

	Definition isPush {t: Type} (__input : stack t) : Prop :=
		match __input with
			  Push _ _ => True
			| _ => False
		end.

	Definition getPushTop {t: Type} (__input : stack t) : isPush __input -> t :=
		match __input with
			  Push top _ => fun __precondition => top
			| _ => fun __precondition => match __precondition with end
		end.

	Definition getPushPop {t: Type} (__input : stack t) : isPush __input -> stack t :=
		match __input with
			  Push _ pop => fun __precondition => pop
			| _ => fun __precondition => match __precondition with end
		end.
End CoStack.

Module Stack.
	Parameter Label : Type.

	CoInductive stack (t : Type) :=
		  Empty
		| Push (top : t) (pop : stack t)
		| Labeled (__tag : Label) (__data : stack t)
		| Reference (__tag : Label).

	Definition isEmpty {t: Type} (__input : stack t) : Prop :=
		match __input with
			  Empty  => True
			| _ => False
		end.

	Definition isPush {t: Type} (__input : stack t) : Prop :=
		match __input with
			  Push _ _ => True
			| _ => False
		end.

	Definition isLabeled {t: Type} (__input : stack t) : Prop :=
		match __input with
			  Labeled _ _ => True
			| _ => False
		end.

	Definition isReference {t: Type} (__input : stack t) : Prop :=
		match __input with
			  Reference _ => True
			| _ => False
		end.

	Definition getPushTop {t: Type} (__input : stack t) : isPush __input -> t :=
		match __input with
			  Push top _ => fun __precondition => top
			| _ => fun __precondition => match __precondition with end
		end.

	Definition getPushPop {t: Type} (__input : stack t) : isPush __input -> stack t :=
		match __input with
			  Push _ pop => fun __precondition => pop
			| _ => fun __precondition => match __precondition with end
		end.

	Definition getLabeled__tag {t: Type} (__input : stack t) : isLabeled __input -> Label :=
		match __input with
			  Labeled __tag _ => fun __precondition => __tag
			| _ => fun __precondition => match __precondition with end
		end.

	Definition getLabeled__data {t: Type} (__input : stack t) : isLabeled __input -> stack t :=
		match __input with
			  Labeled _ __data => fun __precondition => __data
			| _ => fun __precondition => match __precondition with end
		end.

	Definition getReference__tag {t: Type} (__input : stack t) : isReference __input -> Label :=
		match __input with
			  Reference __tag => fun __precondition => __tag
			| _ => fun __precondition => match __precondition with end
		end.

	Inductive subterm {t: Type} (__root : stack t) : stack t -> Type :=
		  SubRoot : subterm __root __root
		| SubLabeled : forall __tag __data, subterm __root (Labeled t __tag __data) -> subterm __root __data
		| SubPushPop : forall top pop, subterm __root (Push t top pop) -> subterm __root pop.
End Stack.


From Undecidability.L Require Import Tactics.LTactics.
From Undecidability.L.Datatypes Require Import Lists LVector.
From Complexity.Libs Require Import PSLCompat.
From Complexity.Complexity Require Import NP Definitions Monotonic.
From Undecidability.TM Require Import TM_facts.
From Complexity.L.AbstractMachines Require Import FlatPro.Computable.LPro.
From Undecidability.L.AbstractMachines Require Import FlatPro.Programs.
From Complexity.NP Require Import LMGenNP TMGenNP_fixed_mTM M_LM2TM.

From Undecidability.TM.L Require M_LHeapInterpreter.

Set Default Proof Using "Type".

(* Check LMtoTM.M. *)

From Undecidability Require Import LSum.
From Complexity Require Import L.TM.CompCode.

From Undecidability Require Import Alphabets.

Import ProgrammingTools.

Module TrueOrDiverge.
  Import TM.TM ProgrammingTools CaseList CaseBool Code.Decode Code.DecodeList.

  Section sec.
    Variable (n:nat) (sig : finType) (M' : pTM sig bool n).

    Definition M := If M' Nop Diverge.

    Lemma Realise R' (H' : M' ⊨ R'):
      M ⊨ (fun tin out => R' tin (true,snd out)).
    Proof.
      eapply Realise_monotone.
      { eapply If_Realise. eassumption. now TM_Correct. now apply Diverge_Realise. }
      hnf. intros x [[] y]. intros [H|H].
      -cbn in H. destruct H as (?&?&<-). easy.
      -exfalso. cbn in H. firstorder.
    Qed.

    Import TM.

    Lemma Terminates R' (HR' : M' ⊨ R') T' (HT' : projT1 M' ↓ T'):
      projT1 M ↓ (fun tin k => T' tin (k-1) /\ 0 < k /\ forall tout, ~ R' tin (false,tout)).
    Proof.
      eapply TerminatesIn_monotone.
      { eapply If_TerminatesIn. 1,2:eassumption. now TM_Correct. now apply Canonical_TerminatesIn. }
      intros tin [] (HTtin&Hfalse). easy.
      do 2 eexists;repeat simple apply conj. eassumption.
      2:{ intros ? ? ?. destruct b. reflexivity. now exfalso. }
      nia.
    Qed.
  End sec.
End TrueOrDiverge.

Arguments LMtoTM.M : clear implicits.

(*move*)
Lemma initValue_sizeOfTape (sig sigX X : Type) (cX : codable sigX X) (I : Retract sigX sig) (x : X):
  sizeOfTape (initValue cX I x) = size x + 2.
Proof.
  cbn. autorewrite with list. cbn. now unfold size.
Qed.

Lemma initRight_sizeOfTape sig :
  sizeOfTape (initRight sig) = 1.
Proof.
  cbn. nia.
Qed.

Module M.
  Section M.
    Arguments LMtoTM.M : clear implicits.
    Definition sig := (finType_CS (M_LHeapInterpreter.sigStep + sigList bool)).

    Definition sig__reg : encodable sig := LFinType.encodable_finType.

    Definition Retr1 : Retract _ sig := (Retract_inl _ (Retract_id _)).
    Definition Retr2 : Retract _ sig := (Retract_inr _ (Retract_id _)).

    Let n := 11.
    Definition M : pTM _ _ n := TrueOrDiverge.M (LMtoTM.M sig Retr1 Retr2).
    Definition ts__start : Pro -> tapes (sig^+) (n-1) :=
      (fun P => CodeTM.initValue _ (@LMtoTM.retr__pro _ Retr1) P ::: Vector.const (CodeTM.initRight _) (n-2)).

    Definition Rel : pRel (sig ^+) unit 11 :=
      fun tin _ =>
        forall P t__cert, tin = t__cert:::ts__start P
                   -> exists bs : list bool,
            t__cert ≃(Retr2) bs /\
            (exists (sigma' : LM_heap_def.state) (k : nat), evaluatesIn LM_heap_def.step k (initLMGen P (compile (enc (rev bs)))) sigma').

    Definition Realise :
      M ⊨
        (fun tin _ =>
           forall P t__cert, tin = t__cert:::ts__start P
                      -> exists bs : list bool,
               t__cert ≃(Retr2) bs /\
               (exists (sigma' : LM_heap_def.state) (k : nat), evaluatesIn LM_heap_def.step k (initLMGen P (compile (enc (rev bs)))) sigma')).
    Proof.
      unfold M. eapply Realise_monotone.
      1:now eapply TrueOrDiverge.Realise, LMtoTM.Realise.
      intros ? out H P t__cert ->. hnf in H|-*. specialize (H P).
      apply H.
      -apply CodeTM.initValue_contains.
      -intros ?. cbn - [Vector.const]. rewrite Vector.const_nth. now apply CodeTM.initRight_isVoid.
    Qed.

    Definition time := @f__UpToC _ _ (projT1 (@LMtoTM._Terminates sig Retr1 Retr2)).

    Definition Terminates :
      projT1 M ↓ (fun tin k => 0 < k /\
                            exists P k__LM t__cert (bs : list bool),
                              tin = t__cert ::: ts__start P
                              /\ t__cert ≃(Retr2) bs
                              /\ (exists sigma' : LM_heap_def.state, evaluatesIn LM_heap_def.step k__LM (initLMGen P (compile (enc (rev bs)))) sigma')
                              /\ time (k__LM, sizeOfmTapes tin) <= k-1).
    Proof.
      unfold M. eapply TerminatesIn_monotone.
      {eapply TrueOrDiverge.Terminates. now apply LMtoTM.Realise. apply LMtoTM.Terminates. }
      intros tin k (HkPos&P&k__LM&t__cert&bs&->&Ht__cert&HLM&Htime). unfold LMtoTM.Ter.
      split.
      2:{ split. easy. unfold LMtoTM.Rel. intros _ H. eapply (H P).
          -apply CodeTM.initValue_contains.
          -intros ?. cbn - [Vector.const]. rewrite Vector.const_nth. now apply CodeTM.initRight_isVoid.
          -eauto.
      }
      exists P,k__LM.
      repeat simple apply conj.
      -apply CodeTM.initValue_contains.
      -intros ?. cbn - [Vector.const]. rewrite Vector.const_nth. now apply CodeTM.initRight_isVoid.
      -right. exists bs;split. all:easy.
      -eassumption.
    Qed.
  End M.

  Lemma sizeStart t__cert P:
    sizeOfmTapes (t__cert ::: M.ts__start P)
    = max (sizeOfTape t__cert) (size P + 2).
  Proof.
    unfold sizeOfmTapes. rewrite Vector.fold_left_right_assoc_eq. 2:nia. cbn - [Vector.const initValue initRight].
    rewrite <- Vector.fold_left_right_assoc_eq.  2:nia.
    set (tmp:= VectorDef.const _ _). change (VectorDef.fold_left _ _ _) with (sizeOfmTapes tmp).
    rewrite initValue_sizeOfTape.
    replace (sizeOfmTapes tmp) with 1. nia.
    subst tmp. clear.
    unfold sizeOfmTapes. rewrite Vector.fold_left_right_assoc_eq. 2:nia.
    generalize 8 as x. induction x.
    -reflexivity.
    -cbn in *. now rewrite <- IHx.
  Qed.

End M.

From Complexity Require Import PolyTimeComputable.

(*REMOVE?*)
Import GenericNary UpToCNary.
From Coq Require Import CRelationClasses CMorphisms.

(* TODO MOVE :tidy up *)
Lemma pTC_length X `{encodable X}: polyTimeComputable (@length X).
Proof.
  evar (time:nat -> nat).
  eexists time.
  { eapply computableTime_timeLeq. 2:exact _.
    solverec. rewrite size_list_enc_r. set (n:=L_facts.size _). [time]:refine (fun n => _). unfold time. reflexivity.
  }
  1,2:unfold time;now smpl_inO.
  eexists (fun n => _).
  {intros. rewrite !LNat.size_nat_enc, size_list_enc_r. set (n:= L_facts.size _). reflexivity. }
    1,2:unfold time;now smpl_inO.
Qed.

Smpl Add 1 simple apply pTC_length : polyTimeComputable.

Lemma pTC_Code_size X sig `{encodable X} `{encodable sig}  (cX : codable sig X):
  polyTimeComputable cX -> polyTimeComputable (@Code.size sig X cX).
Proof.
  intros.
  unfold size. repeat smpl polyTimeComputable.
Qed.
Smpl Add 5 simple eapply pTC_Code_size : polyTimeComputable.

Section cons.

  Lemma pTC_cons X Y `{regX:encodable X} `{regY:encodable Y} f (g : X -> list Y):
    polyTimeComputable f -> polyTimeComputable g -> polyTimeComputable (fun (x:X) => f x :: g x).
  Proof.
    intros. specialize termT_cons with (X:=Y) as H.
    eapply polyTimeComputable_composition2. 1,2:easy.
    evar (c:nat). eexists (fun _ => c).
    { extract. solverec. now unfold c. }
    1,2:now smpl_inO.
    eexists (fun n => n + 1). 2,3:now smpl_inO.
    {intros. rewrite size_list_cons. rewrite !LProd.size_prod. unfold c__listsizeCons. nia.
    }
  Qed.
End cons.

Smpl Add 5 lazymatch goal with
             |- polyTimeComputable (fun X => _ :: _) => apply pTC_cons
           end: polyTimeComputable.

Section Vcons.
  Import Undecidability.Shared.Libs.PSL.Vectors.Vectors.
  Import Vector.
  Local Arguments VectorDef.to_list : simpl never.
  Global Instance termT_cons n X {regX : encodable X} : computableTime' (fun x => @Vector.cons X x n) (fun a aT => (1,fun A AT => (4,tt))).
  Proof.
    computable_casted_result.
    change (fun (x : X) (x0 : Vector.t X n) => VectorDef.to_list (x ::: x0)) with (fun (x : X) (x0 : Vector.t X n) => x :: Vector.to_list x0).
    extract. solverec.
  Qed.

  Lemma pTC_Vector_cons X Y `{regX:encodable X} `{regY:encodable Y} n f (g : X -> Vector.t Y n):
    polyTimeComputable f -> polyTimeComputable g -> polyTimeComputable (fun (x:X) => f x ::: g x).
  Proof.
    intros. specialize termT_cons with (n:=n) (X:=Y) as H.
    set (cons := (fun (x :Y) => @Vector.cons _ x n)) in H.
    change (polyTimeComputable (fun x : X => cons (f x) (g x))).
    eapply polyTimeComputable_composition2. 1,2:easy.
    fold cons in H.
    evar (c:nat).
    eexists (fun _ => c).
    { extract. solverec. now unfold c. }
    1,2:now smpl_inO.
    eexists (fun n => n + 1). 2,3:now smpl_inO.
    {intros. unfold cons. rewrite enc_vector_eq.
     change (to_list (fst x ::: snd x)) with (fst x :: to_list (snd x)).
     rewrite size_list_cons. rewrite !LProd.size_prod.  rewrite <- enc_vector_eq.
     set (L_facts.size (enc (fst x))). set (L_facts.size (enc (snd x))). unfold c__listsizeCons. nia.
    }
  Qed.
End Vcons.
Smpl Add 5 lazymatch goal with
             |- polyTimeComputable (fun X => _ ::: _) => apply pTC_Vector_cons
           end: polyTimeComputable.

Lemma mono_map_time X `{encodable X} (f: nat -> nat) (xs: list X):
  monotonic f
  -> sumn (map (fun x => f (L_facts.size (enc x))) xs) <= length xs * f (L_facts.size (enc xs)).
Proof.
  intros Hf.
  induction xs. reflexivity.
  cbn. rewrite size_list_cons,IHxs. hnf in Hf.
  rewrite (Hf (L_facts.size (enc a)) (L_facts.size (enc a) + L_facts.size (enc xs) + 5)). 2:nia.
  rewrite (Hf (L_facts.size (enc xs)) (L_facts.size (enc a) + L_facts.size (enc xs) + 5)). 2:nia. reflexivity.
Qed.

Lemma pTC_map X Y `{encodable X} `{encodable Y} (f:X -> Y):
  polyTimeComputable f -> polyTimeComputable (map f).
Proof.
  intros Hf.
  evar (time:nat -> nat). exists time. set (map f). extract.
  {solverec. rewrite (correct__leUpToC (mapTime_upTo _)).
   rewrite mono_map_time. 2:now apply mono__polyTC. set (L_facts.size _) as n.
   unshelve erewrite (_ : length x <= n). now apply size_list_enc_r.
   [time]:intro. unfold time. reflexivity.
  }
  1,2:now unfold time;smpl_inO.
  evar (size:nat -> nat). exists size.
  {intros x. rewrite size_list,sumn_map_add,sumn_map_c,map_map,map_length.
   rewrite sumn_map_le_pointwise.
   2:{ intros ? _. apply (bounds__rSP Hf). }
   rewrite mono_map_time. 2:eapply mono__rSP.
   set (L_facts.size _) as n.
   unshelve erewrite (_ : length x <= n). now apply size_list_enc_r.
   [size]:intro. unfold size. reflexivity.
  }
  1,2:now unfold size;smpl_inO.
Qed.

Lemma pTC_concat X Y `{encodable X} `{encodable Y} (f:X -> list (list Y)):
  polyTimeComputable f -> polyTimeComputable (fun x => concat (f x)).
Proof.
  intros Hf.
  evar (time:nat -> nat). exists time. extract.
  {solverec. rewrite UpToC_le.
   rewrite sumn_map_le_pointwise.
   2:{ intros ? ?. apply size_list_enc_r. }
   setoid_rewrite mono_map_time with (f:=fun x => x). 2:now hnf.
   rewrite !size_list_enc_r.

   rewrite ! (bounds__rSP Hf).
   set (n:=L_facts.size _).
   [time]:intro. unfold time. reflexivity.
  }
  1,2:now unfold time;smpl_inO.
  evar (size:nat -> nat). exists size.
  {intros x.
   rewrite size_list, sumn_map_add,sumn_map_c.
   rewrite concat_map,sumn_concat.
   rewrite length_concat.
   rewrite map_map.
   rewrite sumn_le_bound with (c:= length (concat (f x)) * resSize__rSP Hf (L_facts.size (enc x))).
   2:{ intros ? (?&<-&HIn)%in_map_iff. rewrite sumn_le_bound with (c:=L_facts.size (enc x0)).
       2:{  intros ? (?&<-&?)%in_map_iff. now apply size_list_In. }
       rewrite map_length,length_concat. rewrite <- bounds__rSP.
       rewrite size_list_In. 2:eassumption.
       apply Nat.mul_le_mono. 2:reflexivity.
       eapply sumn_le_in. now apply in_map_iff.
   }
   rewrite length_concat,map_length.
   unshelve erewrite (_ : (sumn (map (length (A:=Y)) (f x)) <= resSize__rSP Hf (L_facts.size (enc x)))).
   { rewrite <- bounds__rSP,size_list.
     rewrite <- sumn_map_le_pointwise with (f2:=(fun x0 : list Y => L_facts.size (enc x0) + 5)) (f1:= @length _).
     2: now intros; rewrite <- size_list_enc_r. nia.
   }
    unshelve erewrite (_ : length (f x) <= resSize__rSP Hf (L_facts.size (enc x))).
   { rewrite <- bounds__rSP,size_list. rewrite sumn_map_add,sumn_map_c. unfold c__listsizeNil, c__listsizeCons. nia.
   }
   set (L_facts.size _). [size]:intros n. unfold size. reflexivity.
  }
  1,2:unfold size;smpl_inO.
Qed.

Lemma pTC_app X Y `{encodable X} `{encodable Y} (f1 f2:X -> list Y):
  polyTimeComputable f1 -> polyTimeComputable f2 -> polyTimeComputable (fun x => f1 x ++ f2 x).
Proof.
  intros Hf1 Hf2.
  eapply polyTimeComputable_composition2. 1,2:eauto.
  evar (time : nat -> nat). exists time. extract.
     {solverec.
      unshelve erewrite (_: |a| <= L_facts.size (enc (a,b))).
      { rewrite LProd.size_prod,size_list_enc_r;cbn. nia. }
      set (L_facts.size _). [time]:intro. now unfold time.
     }
     1,2:now unfold time;smpl_inO.
     { evar (size : nat -> nat). exists size.
       {
         intros [a b]. rewrite LProd.size_prod, !size_list,map_app,sumn_app,!sumn_map_add,!sumn_map_c.
         cbn [fst snd].
         [size]:exact (fun x => x + 4). unfold size. lia.
       }
       all:unfold size;smpl_inO.
     }
Qed.

Lemma pTC_initValue X  sig tau `{encodable X} `{encodable sig} `{encodable tau} (cX : codable sig X) (r:Retract sig tau) :
  polyTimeComputable cX -> polyTimeComputable (Retr_f (Retract:=r)) ->  polyTimeComputable (initValue cX r).
Proof.
  unfold initValue. intros cX_pTC r_pTC.
  eapply polyTimeComputable_composition.
  2:{ refine (_ : polyTimeComputable (fun x => (midtape [] (inl START)) x)).
      exists (fun _ => 5). extract.
      Unshelve. solverec. 1,2:now smpl_inO.
      evar (size : nat -> nat). exists size. unfold enc at 1;cbn;intros x.
      set (n0:=L_facts.size (enc x)). [size]:intros n0. repeat (unfold enc,size; cbn). reflexivity.
      all:unfold size. all:smpl_inO.
  }
  eapply pTC_app.
  2:now apply pTC_cnst.
  eapply polyTimeComputable_composition.
  2:{ eapply pTC_map. exists (fun _ => 4). extract. solverec.  1,2:now smpl_inO.
      exists (fun x => x+4).
      {intros. now setoid_rewrite size_sum. }
      all:smpl_inO.
  }
  unfold Encode_map. cbn.
  eapply polyTimeComputable_composition. eassumption.
  eapply pTC_map. eassumption.
Qed.
Smpl Add 5 unshelve simple eapply pTC_initValue : polyTimeComputable.

Import M_LHeapInterpreter.

From Complexity Require Import PolyTimeComputable.

Lemma pTC_Encode_Com : polyTimeComputable (Encode_Com).
Proof.
  unfold Encode_Com;cbn. unfold Com_to_sum.
  change (fun x1 : sigNat => sigSum_X x1) with (@sigSum_X sigNat ACom).
  eexists (fun x => x*(11 + c__app + c__map) + 16 + c__app + c__map).
  {extract. solverec. rewrite map_time_const,app_length,!repeat_length,size_Tok_enc. cbn [length].
    nia. }
  1,2:now smpl_inO.
  eexists (fun x => x*5 + 33).
  { intros [];cbn. 2-4:now cbv.
    rewrite size_list;unfold enc;cbn - ["+"].
    rewrite map_app,map_repeat,sumn_map_add,sumn_map_c,map_app,sumn_app,map_repeat,map_map,app_length,repeat_length,map_length,sumn_repeat.
    unfold enc. cbn;ring_simplify. rewrite LNat.size_nat_enc. unfold LNat.c__natsizeS, LNat.c__natsizeO, c__listsizeNil, c__listsizeCons.
 nia.
  }
  1,2:now smpl_inO.
Qed.

Lemma pTC_Encode_Prog : polyTimeComputable (Alphabets.Encode_Prog).
Proof.
  unfold Alphabets.Encode_Prog,Encode_list. cbn.
  eapply polyTimeComputable_proper_eq_flip. hnf. now setoid_rewrite encode_list_concat at 1.
  eapply pTC_app. 2:now apply pTC_cnst.
  eapply pTC_concat,pTC_map,polyTimeComputable_composition2.
  now apply pTC_cnst.
  eapply polyTimeComputable_composition.
  exact pTC_Encode_Com. eapply pTC_map.
  {eexists (fun x => _). eapply term_sigList_X. 1,2:now smpl_inO.
   eexists (fun x => _). intros x. rewrite size_sigList. set (L_facts.size _). reflexivity. all:smpl_inO.
  }
  repeat smpl polyTimeComputable.
Qed.

Smpl Add 1 simple eapply pTC_Encode_Prog : polyTimeComputable.

Lemma pTC_inl X Y `{encodable X} `{encodable Y} : polyTimeComputable (@inl X Y).
Proof.
  eexists (fun x => _). eapply term_inl. 1, 2: smpl_inO.
  eexists (fun x => _). intros x. rewrite size_sum. set (L_facts.size (enc x)). reflexivity.
  all: smpl_inO.
Qed.
Smpl Add 1 eapply pTC_inl : polyTimeComputable.

From Complexity.Complexity Require Import Subtypes.
Import Datatypes.Lists Datatypes.LBool.
Lemma LMGenNP_to_TMGenNP_mTM:
  LMGenNP (list bool) ⪯p mTMGenNP_fixed (projT1 M.M).
Proof.
  evar (f__size:nat -> nat).
  enough (Hcert_f__size : forall maxSize (bs : list bool) sig R, size (enc bs) <= maxSize -> sizeOfTape (initValue (sig:=sig) _ R bs) <= f__size maxSize).

  evar (f__steps:nat * Pro * nat -> nat).
  enough (Hf__steps : forall steps P maxSize t__cert k__LM,
             sizeOfTape t__cert <= f__size maxSize
             -> k__LM <= steps ->
             M.time (k__LM, sizeOfmTapes (t__cert ::: M.ts__start P)) <= f__steps (steps,P,maxSize)).

  eapply @reducesPolyMO_intro_restrictBy_both with
      (f:=fun '(P,maxSize,steps) => (M.ts__start P,f__size maxSize,S (f__steps (steps,P,maxSize)))).
  2:intros [[P maxSize] steps] H; split.
  2:{ hnf in H|-*. destruct H as ((s&->&s__proc)&HsmallCert&Hk).
      intros t__cert' k res' HM.
      specialize (M.Realise HM) as H'. hnf in H'. specialize H' with (1:=eq_refl) as (bs'&Hbs'&(sigma'&k__LM'&HbsRed')).
      specialize HsmallCert with (1:=HbsRed') as (bs&res__LM&Hbs&HbsRed&Hter__LM). clear HM k res' t__cert' bs' Hbs' sigma' k__LM' HbsRed'.
      apply star_pow in HbsRed as (k__LM&HbsRed).
      assert (Hk__LM : k__LM <= steps).
      { eapply Hk. exact Hbs. split. all:eassumption. }
      edestruct M.Terminates as (conf'&eq).
      2:{ eexists (initValue _ _ (rev bs)),_. split. 2:eassumption. eapply Hcert_f__size. rewrite size_rev. easy. }
      split. now clear;Lia.nia.
      eexists _,_,_,(rev bs).
      repeat simple apply conj.
      1:now reflexivity.
      1:now apply initValue_contains.
      2:{
        unshelve erewrite (_ : forall x, S x - 1 = x). 1:now clear;nia.
        apply Hf__steps. 2:eassumption. eapply Hcert_f__size.  rewrite size_rev. easy.
      }
      rewrite rev_involutive. unfold evaluatesIn;eauto.
  }
  3:{ intros steps P maxSize t__cert k__LM Hsize Hk__LM.
      rewrite M.sizeStart.
      unfold M.time.
      rewrite UpToC_le.
      rewrite !Hk__LM. clear Hk__LM k__LM.
      rewrite !Hsize. clear Hsize t__cert.
      [f__steps]:refine (fun '(steps,P,maxSize) => _). unfold f__steps. reflexivity.
  }
  3:{ intros maxSize bs sig R Hsize. rewrite initValue_sizeOfTape.

      specialize @correct__leUpToC with (l:=BoollistEnc.boollist_size) (x:=bs) as ->.
      rewrite <- size_list_enc_r in Hsize. rewrite Hsize.
      [f__size]:refine (fun n => _). subst f__size;cbn beta. reflexivity.
  }

  2:{
    destruct H as ((s&->&s__proc)&HsmallCert&Hsmallk).
    unfold LMGenNP, mTMGenNP_fixed.
    split.
    -intros (cert' & HcertSize' & sigma'' & k' &Hk' &HR').
     edestruct M.Terminates with (k:= S (f__steps (steps,compile s,maxSize))) as (tout&Hout).
     { split. easy. eexists _,_,_,(rev cert'). rewrite rev_involutive. repeat simple apply conj.
       1:reflexivity.
       2:eexists;exact HR'.
       1:now apply initValue_contains.
       { unshelve erewrite (_ : forall x, S x - 1 = x). 1:now clear;nia.
         apply Hf__steps. 2:eassumption.
         eapply Hcert_f__size. now rewrite size_rev.
       }
     }
     do 2 eexists.
     2:{
       eexists. eassumption. }
     eapply Hcert_f__size. now rewrite size_rev.
    -intros (t__cert&Hsize_t__cert&(res&Hres)).
     specialize (M.Realise Hres) as H'. hnf in H'. specialize H' with (1:=eq_refl) as (bs'&Hbs'&(sigma'&k__LM'&HbsRed')).
      specialize HsmallCert with (1:=HbsRed') as (bs&res__LM&Hbs&HbsRed&Hter__LM). clear Hres bs' Hbs' sigma' k__LM' HbsRed'.
      apply star_pow in HbsRed as (k__LM&HbsRed).
      assert (Hk__LM : k__LM <= steps).
      { eapply Hsmallk. exact Hbs. split. all:eassumption. }
      exists bs. repeat simple apply conj. 1:easy. unfold evaluatesIn; eauto 10.
  }
  {
    clear Hf__steps Hcert_f__size.

    nary apply pTC_destructuringToProj.
(*     specialize pTC_destructuringToProj with (domain:=[nat;nat;list Tok]) as h. cbn in h. refine ( h _ _ _ _ _). *)
    enough (polyTimeComputable f__size).
    enough (polyTimeComputable f__steps).
    repeat smpl polyTimeComputable.
    -unfold M.ts__start.
    unfold Alphabets.Encode_Prog.

    repeat smpl polyTimeComputable.
    {
      unfold Retr_f. cbn. unfold retr_comp_f,retract_inl_f.
      eapply polyTimeComputable_composition.
      eapply polyTimeComputable_composition.
      eapply polyTimeComputable_composition.
      eapply polyTimeComputable_composition.

      now eapply pTC_id. 3, 4: smpl polyTimeComputable.
      2:{ eexists (fun x => _). eapply term_sigList_X. 1,2:now smpl_inO.
          eexists (fun x => _). intros x. rewrite size_sigList. set (size _). reflexivity. all:smpl_inO.
      }
      { eexists (fun x' => _). now apply (term_sigPair_Y).  1,2:now smpl_inO.
        eexists (fun x => 4 + _). intros x. unfold enc;cbn. set (size _). reflexivity. all:smpl_inO.
      }
    }
    -unfold f__steps. nary apply pTC_destructuringToProj.
    (*     specialize pTC_destructuringToProj with (domain:=[nat;nat;list Tok]) as h. cbn in h. refine ( h _ _ _ _ _). *)
     repeat smpl polyTimeComputable.
    -unfold f__size.
     repeat smpl polyTimeComputable.
  }
Qed.


From Coq Require Import Cyclic31.
From Coq Require Import List.
From Coq Require Import Znumtheory.
From ConCert.Utils Require Import Extras.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import BoundedN.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import Monad.
From ConCert.Execution Require Import ResultMonad.
From ConCert.Execution Require Import Serializable.
From ConCert.Execution Require Import ContractCommon. Import AddressMap.
From ConCert.Execution.Test Require Import LocalBlockchain.
From ConCert.Examples.BoardroomVoting Require Import BoardroomMath.
From ConCert.Examples.BoardroomVoting Require Import BoardroomVoting.

Import ListNotations.

Local Open Scope Z.
Local Open Scope broom.

(*
Definition modulus : bigZ := 1552518092300708935130918131258481755631334049434514313202351194902966239949102107258669453876591642442910007680288864229150803718918046342632727613031282983744380820890196288509170691316593175367469551763119843371637221007210577919.
Definition generator : bigZ := 2.
*)
Definition modulus : Z := 201697267445741585806196628073.
Definition four := 4%nat.
Definition seven := 7%nat.
Definition _1234583932 := 1234583932.
Definition _23241 := 23241.
Definition _159338231 := 159338231.

(* Definition modulus : Z := 13. *)
Definition generator : Z := 3.

Axiom modulus_prime : prime modulus.
Import Lia.
Module ZAxiomParams <: BoardroomAxiomsZParams.
  Definition p := modulus.
  Definition isprime := modulus_prime.
  Program Definition prime_ge_2 : p >= 2.
  Proof. easy. Defined.
End ZAxiomParams.
Module BVZAxioms := BoardroomAxiomsZ ZAxiomParams. Import BVZAxioms.

#[local]
Existing Instance boardroom_axioms_Z.

Lemma generator_nonzero : generator !== 0.
Proof. discriminate. Qed.

Axiom generator_is_generator :
  forall z,
    ~(z == 0) ->
    exists! (e : Z), (0 <= e < order - 1)%Z /\ pow generator e == z.

#[local]
Instance generator_instance : Generator boardroom_axioms_Z :=
  {| BoardroomMath.generator := generator;
     BoardroomMath.generator_nonzero := generator_nonzero;
     generator_generates := generator_is_generator; |}.

Definition num_parties : nat := seven.
Definition votes_for : nat := four.

(* a pseudo-random generator for secret keys *)
Definition sk n := (Z.of_nat n + _1234583932) * (modulus - _23241)^_159338231.

(* Make a list of secret keys, here starting at i=7 *)
Definition sks : list Z := map sk (seq seven num_parties).

(* Make a list of votes for each party *)
Definition svs : list bool :=
  Eval compute in map (fun _ => true)
                      (seq 0 votes_for)
                  ++ map (fun _ => false)
                         (seq 0 (num_parties - votes_for)).

(* Compute the public keys for each party *)
Time Definition pks : list Z :=
  Eval vm_compute in map compute_public_key sks.

Definition rks : list Z :=
  Eval vm_compute in map (reconstructed_key pks) (seq 0 (length pks)).

(* In this example we just use xor for the hash function, which is
   obviously not cryptographically secure. *)
Definition oneN : N := 1%N.

Definition hash_func (l : list positive) : positive :=
  N.succ_pos (fold_left (fun a p => N.lxor (Npos p) a) l oneN).

Definition AddrSize := (2^128)%N.
#[local]
Instance Base : ChainBase := LocalChainBase AddrSize.
#[local]
Instance ChainBuilder : ChainBuilderType := LocalChainBuilderImpl AddrSize true.

Module Params <: BoardroomParams.
  Definition A : Type := Z.
  Definition H : list positive -> positive := hash_func.
  Definition ser : Serializable A := _.
  Definition axioms : BoardroomAxioms A := _.
  Definition gen : Generator axioms := _.
  Axiom d : DiscreteLog axioms gen.
  Definition discr_log : DiscreteLog axioms gen := d.
  Definition Base := Base.
End Params.

Module BV := BoardroomVoting Params. Import BV.

(* Compute the signup messages that would be sent by each party.
   We just use the public key as the chosen randomness here. *)
Definition _3 := 3%nat.
Definition _5 := 5.
Definition _11 := 11.

Time Definition signups : list Msg :=
  Eval vm_compute in map (fun '(sk, pk, i) => make_signup_msg sk _5 i)
                             (zip (zip sks pks) (seq 0 (length sks))).

(* Compute the submit_vote messages that would be sent by each party *)
(* Our functional correctness proof assumes that the votes were computed
   using the make_vote_msg function provided by the contract.
   In this example we just use the secret key as the random parameters. *)
Definition votes : list Msg :=
  Eval vm_compute in map (fun '(i, sk, sv, rk) => make_vote_msg pks i sk sv sk sk sk)
                             (zip (zip (zip (seq 0 (length pks)) sks) svs) rks).

Definition A a :=
  BoundedN.of_Z_const AddrSize a.

Local Open Scope nat.
Definition addrs : list Address.
Proof.
  let rec add_addr z n :=
    match n with
    | O => constr:(@nil Address)
    | S ?n => let tail := add_addr (z + 1)%Z n in
              constr:(cons (A z) tail)
    end in
  let num := eval compute in num_parties in
  let tm := add_addr _11%Z num in
  let tm := eval vm_compute in tm in
  exact tm.
Defined.

Definition voters_map : AddrMap unit := AddressMap.of_list (map (fun a => (a, tt)) addrs).

Definition five := 5%nat.

Definition deploy_setup :=
  {| eligible_voters := voters_map;
     finish_registration_by := _3;
     finish_commit_by := None;
     finish_vote_by := five;
     registration_deposit := 0; |}.

Local Open Scope list.
Definition boardroom_example : option nat :=
  let chain : ChainBuilder := builder_initial in
  let creator : Address := A 10 in
  let add_block (chain : ChainBuilder) (acts : list Action) :=
      let next_header :=
          {| block_height := S (chain_height chain);
             block_slot := S (current_slot chain);
             block_finalized_height := finalized_height chain;
             block_creator := creator;
             block_reward := 50; |} in
      option_of_result (builder_add_block chain next_header acts) in
  do chain <- add_block chain [];
  let dep := build_act creator creator (create_deployment 0 boardroom_voting deploy_setup) in
  do chain <- add_block chain [dep];
  do caddr <- hd_error (AddressMap.keys (lc_contracts (lcb_lc chain)));
  let send addr m := build_act addr addr (act_call caddr 0 (serialize m)) in
  let calls := map (fun '(addr, m) => send addr m) (zip addrs signups) in
  do chain <- add_block chain calls;
  let votes := map (fun '(addr, m) => send addr m) (zip addrs votes) in
  do chain <- add_block chain votes;
  let tally := build_act creator creator (act_call caddr 0 (serialize tally_votes)) in
  do chain <- add_block chain [tally];
  do state <- contract_state (lcb_lc chain) caddr;
  BV.tally state.

Check (@eq_refl (option nat) (Some votes_for)) <: boardroom_example = Some votes_for.