(** This file is a tutorial to learn how to use the Cerise Program Logic within Coq.
    We will use the modularity of the program logic to use the specification of
    a macro in a program, and show how the macro can be linked via a linking table.

    Prerequisites:
    We assume the user has already followed the first part of the tutorial
    "cerise_tutorial.v" and is able to prove the specification of a program
    with known code using the Cerise Proof Mode. *)

From iris.proofmode Require Import tactics.
From cap_machine Require Import rules proofmode macros_new macros_helpers.
Open Scope Z_scope.

Section increment_macro.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}
          `{MP: MachineParameters}.

  (** The increment macro is a macro that takes a register r (r ≠ r_env), which
      contains a capability C with a permission p ≤ RW, that points to
      an integer n. The macro increments the value of the integer.
      The macro uses the register r_env to perform the arithmetic, and clear
      the result of the register.
   *)
  Definition incr_instrs r r_env : list Word :=
    encodeInstrsW [
      Load r_env r ;
      Add r_env r_env 1;
      Store r r_env;
      Mov r_env 0 ].

  (** Specification of the macro. The proof is an optional exercise. *)
  Lemma incr_macro_spec
    p_pc b_pc e_pc a_prog (* pc *)
    r r_env (* registers of the macro *)
    p (e b a : Addr) n (* capability *)
    w_env
    φ :

    let e_prog := (a_prog ^+ length (incr_instrs r r_env))%a in

    r <> r_env ->

    ExecPCPerm p_pc ->
    SubBounds b_pc e_pc a_prog e_prog ->

    b <= a < e -> (* a is in the bounds of the capability *)
    writeAllowed p = true -> (* p can Read/Write *)

    ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog (* PC points to the prog*)
        ∗ codefrag a_prog (incr_instrs r r_env) (* the prog instruction start at a_prog *)
        ∗ r ↦ᵣ WCap p b e a (* r contains the capability *)
        ∗ r_env ↦ᵣ w_env (* ownership of r_env *)
        ∗ a ↦ₐ WInt n (* content of a, which is an integer *)
         ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog
               ∗ r ↦ᵣ WCap p b e a
               ∗ r_env ↦ᵣ WInt 0 (* cleared register *)
               ∗ a ↦ₐ WInt (n+1) (* incremented value *)
                ∗ codefrag a_prog (incr_instrs r r_env)
               -∗ WP Seq (Instr Executable) {{ φ }}))
       -∗ WP Seq (Instr Executable) {{ φ }}%I.
  Proof.
  intros * Hregs Hpc_perm Hpc_bounds Ha_bounds Hperm.
  iIntros "(HPC& Hprog& Hr& Hrenv& Ha& Hcont)".

  (* 1 - prepare the assertions for the proof *)
  subst e_prog; simpl.
  (* Derives the facts from the codefrag *)
  codefrag_facts "Hprog".
  simpl in *.

  (* 2 - wp rules for each instructions *)
  iInstr "Hprog".
  { split. apply writeA_implies_readA; done. by rewrite withinBounds_true_iff. }
  iGo "Hprog".
  by rewrite withinBounds_true_iff.
  iInstr "Hprog".

  (* 3 - continuation *)
  iApply "Hcont".
  iFrame.
  Qed.

  (** The increment macro is just a list of instructions. In particular,
      it can be used as a part of a bigger list of instructions.
      The specification assumes that the PCC points to the first address of the
      macro, and the list of instructions is _included_ into the bounds of the
      PCC: thus, the specification can be used in the proof of the specification
      of a bigger program.

      The macros are a way to define the program modularly.
      For such short macro, the modularity is a bit "too much", but dealing
      with larger and complex macros (e.g. involving a loop), this modularity
      is necessary.
   *)

  (** The following is a very simple example of program that uses the macro. The
      program assumes that R0 contains a writing capability pointing to the
      memory. It initializes the value of this memory address at 0, calls the
      increment macro to increment the value, and finally loads the
      incremented value in the register R1.

      The reader may notice 3 blocks of instructions, separated by the `++`
      operator. The proof will leverage this block separation using new
      `focus_block` tactics, detailled in `proofmode.md`, section `Focusing a
      sub-block`. They allow us to focus on a block, prove its specification
      locally, and then continue the proof of the global program.
   *)
  Definition prog_instrs: list Word :=
    encodeInstrsW [Store r_t0 0 ] ++
            incr_instrs r_t0 r_t1 ++
            encodeInstrsW [Load r_t1 r_t0 ].

  Lemma prog_spec
    p_pc b_pc e_pc a_prog (* pc *)
    p (e b a : Addr) w (* capability *)
    w_env
    φ :

    let e_prog := (a_prog ^+ length prog_instrs)%a in

    ExecPCPerm p_pc ->
    SubBounds b_pc e_pc a_prog e_prog ->

    b <= a < e -> (* a is in the bounds of the capability *)
    writeAllowed p = true -> (* p can Read/Write *)

    ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog (* PC points to the prog *)
        ∗ codefrag a_prog prog_instrs (* the prog instruction start at a_prog *)
        ∗ r_t0 ↦ᵣ WCap p b e a (* r_t0 contains the capability *)
        ∗ r_t1 ↦ᵣ w_env (* ownership of r_t1 *)
        ∗ a ↦ₐ w (* content of a *)
         ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog
               ∗ r_t0 ↦ᵣ WCap p b e a (* r_t0 contains the capability *)
               ∗ r_t1 ↦ᵣ WInt 1 (* ownership of r_t1 *)
               ∗ a ↦ₐ WInt 1 (* incremented value *)
               ∗ codefrag a_prog prog_instrs
               -∗ WP Seq (Instr Executable) {{ φ }}))
       -∗ WP Seq (Instr Executable) {{ φ }}%I.
  Proof.
  intros * Hpc_perm Hpc_bounds Ha_bounds Hperm.
  iIntros "(HPC& Hprog& Hr& Hrenv& Ha& Hcont)".

  (* 1 - prepare the assertions for the proof *)
  subst e_prog; simpl.
  (* Derives the facts from the codefrag *)
  simpl in *.
  (* We use the new tactic to focus on the first block. *)
  (* Initialisation block *)
  focus_block_0 "Hprog" as "Hintro" "Hnext".
  iInstr "Hintro";[by rewrite withinBounds_true_iff|].
  unfocus_block "Hintro" "Hnext" as "Hprog".

  (* Increment macro *)
  focus_block 1%nat "Hprog" as a_incr Ha_incr "Hincr" "Hnext".
  (* We use the specification of the macro. *)
  iApply (incr_macro_spec with "[- $HPC $Hincr $Hr $Hrenv $Ha]");eauto.
  iNext; iIntros "(HPC &Hr &Hrenv &Ha &Hincr)".
  unfocus_block "Hincr" "Hnext" as "Hprog".

  focus_block 2%nat "Hprog" as a_end Ha_end "Hend" "Hnext".
  iGo "Hend".
  { split. apply writeA_implies_readA; done. by rewrite withinBounds_true_iff.  }
  unfocus_block "Hend" "Hnext" as "Hprog".

  (* 3 - continuation *)
  iApply "Hcont".
  simpl in *.
  replace (a_end ^+1)%a with (a_prog ^+ 6%nat)%a by solve_addr.
  iFrame.
  Qed.

End increment_macro.

Section rclear_macro.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}
          `{MP: MachineParameters}.

  (** In this section, we will use a pre-defined macro in Cerise, `rclear`.
      `rclear` is a macro that clears (puts 0) the list of registers given as
      argument. *)

  (** The following program assumes that the register r0 contains a capability
      that points to a buffer with at least 2 integers.
      It performs the addition of the 2 integers of the buffer and stores the
      result at the address of the second integer.
      Then, it clears all the used registers (to remove every trace of
      the computations) and halts the machine. *)
  Definition secret_add_instrs: list Word :=
    encodeInstrsW
            [Load r_t1 r_t0;
             Lea r_t0 1;
             Load r_t2 r_t0;
             Add r_t1 r_t1 r_t2;
             Store r_t0 r_t1
            ] ++
            rclear_instrs [r_t0;r_t1;r_t2] ++
            encodeInstrsW [Halt].

  (** **** Exercise 3 --- Secret addition
        Define the lemma `secret_add_spec` that specifies the program
        `secret_add_instrs` and prove it.

        Use the tactics to focus and unfocus the block.
        The specification of the `rclear` macro is `rclear_spec`,
        defined in the file `theories/examples/macros_new.v`.

        Hint (specification): TODO ???
        Hint (proof): The specification of `rclear` requires the use of
        the `big_sepM` resource. The `big_sepM` resource [...] use a map.
        We urge the reader to search lemmas about `big_sepM` and
        `gmap`.

        Hint (proof): useful lemmas
        - big_sepM_insert
        - big_sepM_insert_delete
        - delete_insert_ne
        - delete_empty
   *)
  Lemma secret_add_spec
    p_pc b_pc e_pc a_prog (* pc *)
    p (e b a : Addr) (* capability *)
    w1 w2 n1 n2
    φ :

    let e_prog := (a_prog ^+ length secret_add_instrs)%a in

    ExecPCPerm p_pc ->
    SubBounds b_pc e_pc a_prog e_prog ->

    b+2 < e -> (* a is in the bounds of the capability *)
    writeAllowed p = true -> (* p can Read/Write *)

    ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog (* PC points to the prog *)
        ∗ codefrag a_prog secret_add_instrs (* the prog instruction start at a_prog *)
        ∗ r_t0 ↦ᵣ WCap p b e b (* r_t0 contains the capability *)
        ∗ r_t1 ↦ᵣ w1 (* ownership of r_t1 *)
        ∗ r_t2 ↦ᵣ w2 (* ownership of r_t2 *)
        ∗ b ↦ₐ WInt n1 (* content of a *)
        ∗ (b^+1)%a ↦ₐ WInt n2 (* content of a *)
         ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc (a_prog ^+ (length secret_add_instrs - 1))%a
               ∗ r_t0 ↦ᵣ WInt 0  (* ownership of r_t0 *)
               ∗ r_t1 ↦ᵣ WInt 0 (* ownership of r_t1 *)
               ∗ r_t2 ↦ᵣ WInt 0 (* ownership of r_t2 *)
               ∗ b ↦ₐ WInt n1 (* content of a *)
               ∗ (b^+1)%a ↦ₐ WInt (n1 + n2) (* content of a *)
               ∗ codefrag a_prog secret_add_instrs (* the prog instruction start at a_prog *)
               -∗ WP Instr Halted {{ v, φ v }}))
       -∗ WP Seq (Instr Executable) {{ φ }}%I.
    Proof.
    intros * Hpc_perm Hpc_bounds Ha_bounds Hperm.
  iIntros "(HPC& Hprog& Hr0& Hr1& Hr2& Hb0& Hb1& Hcont)".

  (* 1 - prepare the assertions for the proof *)
  subst e_prog; simpl in *.
  (* We use the new tactic to focus on the first block. *)
  (* Initialisation block *)
  focus_block_0 "Hprog" as "Hintro" "Hnext".
  iInstr "Hintro".
  split; [by apply writeA_implies_readA|
          by rewrite withinBounds_true_iff; solve_addr].
  iInstr "Hintro".
  { transitivity (Some (b^+1)%a) ; auto; solve_addr. }
  { destruct p ; auto. }
  iInstr "Hintro".
  split; [by apply writeA_implies_readA|
         by rewrite withinBounds_true_iff; solve_addr].
  iInstr "Hintro".
  iInstr "Hintro".
  by rewrite withinBounds_true_iff; solve_addr.
  unfocus_block "Hintro" "Hnext" as "Hprog".

  (* rclear macro block *)
  focus_block 1%nat "Hprog" as a_clear Ha_clear "Hclear" "Hnext".
  (* We use the specification of the macro. The macro requires a mapping of
  the register to their current value. We already instantiate the mapping. *)
  set rmap := (<[r_t0:=WCap p b e (b ^+ 1)%a]>
                     (<[r_t1:=WInt (n1 + n2)]>
                        (<[r_t2:=WInt n2]> (∅ : gmap RegName Word)))).
  iApply (rclear_spec _ rmap with "[- $Hclear $HPC]");eauto; try set_solver.
  iSplitL "Hr0 Hr1 Hr2"; iNext.
  (* We need to transform the different resources of registers into a
  single resource, the big_sepM resource. *)
  by repeat (iApply big_sepM_insert; [auto | iFrame]).
  iIntros "(HPC &Hrmap &Hclear)".
  unfocus_block "Hclear" "Hnext" as "Hprog".

  (* Final block, which is just the halting instruction. *)
  focus_block 2%nat "Hprog" as a_end Ha_end "Hend" "Hnext".
  iGo "Hend".
  unfocus_block "Hend" "Hnext" as "Hprog".

  (* 3 - continuation *)
  iApply "Hcont".
  simpl in *.
  replace ((a_prog ^+ (9%nat - 1))%a) with a_end by solve_addr.
  iFrame.
  (* It only remains to extract the registers from the mapping.
     We need to split the unique mapping resources into different
     individual registers resources.
   *)
  iDestruct (big_sepM_insert_delete with "Hrmap") as "[Hr0 Hrmap]".
  do 2 (rewrite delete_insert_ne; auto). rewrite delete_empty.
  iDestruct (big_sepM_insert_delete with "Hrmap") as "[Hr1 Hrmap]".
  rewrite delete_insert_ne; auto. rewrite delete_empty.
  iDestruct (big_sepM_insert_delete with "Hrmap") as "[Hr2 _]".
  iFrame.
  Qed.

End rclear_macro.

Section linking_table.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}
          `{MP: MachineParameters}.

  (* Demo with incr_macro for the setup *)

  (* Exercices using malloc and assert *)

 End linking_table.

  (** Outline
    2 steps:
    1. use the macro in the middle of the code (as a real macro)
    2. capture the macro into a sentry-capability (as a function), and use a linking table

    1.1) Demo
    Define a program that use this specification that do the following:
    - takes a capability input
    - store 0 into it
    - use the increment macro

    1.2) Exercise
    Exercise with the rclear macro: specify and prove

    2.1) Demo
    Same program as 1.1, but the increment macro is reachable via
    the linking table (instead of inlined).
    It requires some boilerplate about the linking table and shows
    how to set it up.

    2.2) Exercise
    At last exercise, the reader should be able to use the Cerise macros,
    so why not a program that does the following:
    - dyn alloc a region of memory with malloc
    - stores 42 in the last adresse
    - assert it is 42

    Finally, list the macros available in Cerise *)

  (** Now that you are familiar with the Cerise Proofmode,
      we recommand to try defining a program by yourself, as
      well as its specification.
      We also recommand to continue the tutorial with
      TODO (next file) to learn how to define the specification,
      how to use the logical relation to reason with unknown code,
      and how to deal with local encapsulation, using the call macro.
   *)


From hahn Require Import Hahn.
Require Import Classical.
Require Import Lia.
Require Import IndefiniteDescription.
Require Import PropExtensionality.
From ZornsLemma Require Classical_Wf.
Require Import Events.

Lemma list_max_In (l: list nat) (NNIL: l <> nil):
  In (list_max l) l.
Proof using.
  generalize dependent NNIL. induction l; [by vauto| ].
  ins.
  destruct l eqn:LL.
  { ins. lia. }
  specialize_full IHl; [done| ]. rewrite <- LL in *. clear LL.
  destruct (NPeano.Nat.max_spec_le a (list_max l)); desc.
  { rewrite H0. by right. }
  auto.
Qed.

Definition countP (f: actid -> Prop) l :=
  length (filterP f l).

Add Parametric Morphism : countP with signature
    set_subset ==> eq ==> le as countP_mori.
Proof using.
  ins. unfold countP.
  induction y0.
  { simpls. }
  ins. desf; simpls.
  1,3: lia.
  exfalso. apply n. by apply H.
Qed.

Add Parametric Morphism : countP with signature
    set_equiv ==> eq ==> eq as countP_more.
Proof using.
  ins. unfold countP.
  erewrite filterP_set_equiv; eauto.
Qed.

Lemma countP_strict_mori e l P P'
      (IN : P ⊆₁ P')
      (INP  : ~ P e)
      (INP' :  P' e)
      (INL  : In e l) :
  countP P l < countP P' l.
Proof using.
  generalize dependent e.
  induction l; simpls.
  ins. desf.
  { unfold countP; simpls. desf. simpls.
    apply Lt.le_lt_n_Sm. by apply countP_mori. }
  unfold countP; simpls. desf; simpls.
  { apply Lt.lt_n_S. eapply IHl; eauto. }
  { exfalso. apply n. by apply IN. }
  { apply Lt.le_lt_n_Sm. by apply countP_mori. }
    by apply IHl with (e:=e).
Qed.

Lemma false_acyclic {A} : acyclic (∅₂ : relation A).
Proof using.
  red. rewrite ct_of_trans; [|apply transitiveI].
  all: clear; basic_solver.
Qed.

Lemma fsupp_rt_ct {A} (r : relation A)
      (FSUPP : fsupp r＊) :
  fsupp r⁺.
Proof using.
  intros y. specialize (FSUPP y).
  desf. exists findom.
  ins. apply FSUPP.
  apply rtE. now right.
Qed.

Lemma fsupp_wf_implies_fsupp_ct {A} (r : relation A)
      (WF    : well_founded r)
      (FSUPP : fsupp r) :
  fsupp r⁺.
Proof using.
  apply fsupp_rt_ct.
  red; intros y.
  induction y as [y HH] using (well_founded_ind WF).
  specialize (FSUPP y). desf.
  set (f :=
         fun (a : A) =>
           match
             excluded_middle_informative (r a y)
           with
           | left  PF =>
               proj1_sig (constructive_indefinite_description _ (HH a PF))
           | right _  => nil
           end
      ).
  exists (y :: flat_map f findom).
  ins. apply rtE in REL. red in REL. desf.
  { red in REL. desf. auto. }
  right.
  apply ct_end in REL.
  destruct REL as [z [AA BB]].
  apply in_flat_map.
  exists z. splits.
  { now apply FSUPP. }
  subst f. ins. unfold proj1_sig. desf.
  intuition.
Qed.

Lemma fsupp_map_rel {A B} (f : B -> A)
      (FININJ : forall y, set_finite (fun x => y = f x))
      r (FSUPP : fsupp r) :
  fsupp (f ↓ r).
Proof using.
  unfolder. ins. red in FSUPP.
  specialize (FSUPP (f y)). desf.
  set (g :=
         fun (a : A) =>
           proj1_sig
             (constructive_indefinite_description _ (FININJ a))
      ).
  exists (flat_map g findom).
  ins. apply in_flat_map.
  exists (f x). splits; auto.
  subst g. unfold proj1_sig. desf.
  apply i. splits; auto.
Qed.

Lemma fsupp_dom_map_rel {A B} (f : B -> A)
      r (FSUPP : fsupp r)
      (FININJ : forall y, set_finite (fun x => y = f x /\ dom_rel r y)) :
  fsupp (f ↓ r).
Proof using.
  unfolder. ins. red in FSUPP.
  specialize (FSUPP (f y)). desf.
  set (g :=
         fun (a : A) =>
           proj1_sig
             (constructive_indefinite_description _ (FININJ a))
      ).
  exists (flat_map g findom).
  ins. apply in_flat_map.
  exists (f x). splits; auto.
  subst g. unfold proj1_sig. desf.
  apply i. splits; auto.
  red; eauto.
Qed.

Lemma fsupp_seq_l_map_rel {A B} (f : B -> A) (s : B -> Prop)
      r (FSUPP : fsupp r)
      (FININJ : forall y, set_finite (fun x => y = f x /\ s x)) :
  fsupp (<|s|> ;; (f ↓ r)).
Proof using.
  unfolder. ins. red in FSUPP.
  specialize (FSUPP (f y)). desf.
  set (g :=
         fun (a : A) =>
           proj1_sig
             (constructive_indefinite_description _ (FININJ a))
      ).
  exists (flat_map g findom).
  ins. apply in_flat_map.
  desf.
  exists (f x). splits; auto.
  subst g. unfold proj1_sig. desf.
  intuition.
Qed.

Lemma fsupp_map_rel2 {A B} (f : B -> A)
      (FSURJ : forall y, exists x, y = f x)
      r (FSUPP : fsupp (f ↓ r)) :
  fsupp r.
Proof using.
  unfolder. ins. red in FSUPP.
  unfold map_rel in *.
  destruct (FSURJ y) as [x AA]; subst.
  destruct (FSUPP x) as [l BB].
  exists (map f l).
  ins. apply in_map_iff.
  destruct (FSURJ x0) as [z CC]; subst.
  eexists; eauto.
Qed.

Lemma map_rel_seq2 {A B} {f : A -> B} r r'
      (FSURJ : forall y, exists x, y = f x) :
  f ↓ r ⨾ f ↓ r' ≡ f ↓ (r ⨾ r').
Proof using.
  split.
  { apply map_rel_seq. }
  unfolder. ins. desf.
  specialize (FSURJ z). desf.
  eauto.
Qed.

Lemma set_map_codom_ext {A B : Type} (f : A -> B) (rr : relation B)
      (SUR: forall b, exists a, f a = b):
  codom_rel (f ↓ rr) ≡₁ f ↓₁ codom_rel rr.
Proof using.
  split; [apply set_map_codom| ].
  unfolder. ins. desc. specialize (SUR x0). desc.
  exists a. congruence.
Qed.

Ltac contra name :=
  match goal with
  | |- ?goal => destruct (classic goal) as [? | name]; [done| exfalso]
  end.

Lemma set_infinite_has_element {A: Type} (S: A -> Prop)
      (INF: ~ set_finite S):
  exists e, S e.
Proof using. contra NO. destruct INF. exists nil. ins. edestruct NO; vauto. Qed.

Lemma set_finite_exists_bigger {A}
      (DEC : forall x y : A, {x = y} + {x <> y})
      (s : A -> Prop) (FINDOM : set_finite s)
      (f : nat -> A)
      (INJ : forall n m (EQ : f n = f m), n = m) :
  exists n, forall m (LT : n < m), ~ s (f m).
Proof using.
  red in FINDOM. desf.
  generalize dependent s.
  induction findom; ins; eauto.
  destruct (in_dec DEC a findom) as [|NIN].
  { edestruct IHfindom with (s:=s) as [n NN]; eauto.
    ins. apply FINDOM in IN. desf. }
  edestruct IHfindom with (s:=s \₁ eq a) as [n NN].
  { unfolder. ins. desf. apply FINDOM in IN. desf. }
  destruct (classic (exists ma, f ma = a)) as [|CC]; desf.
  2: { exists n. ins. intros AA.
       apply NN in LT. apply LT. split; eauto. }
  exists (1 + max ma n). ins. intros AA.
  set (BB:=AA).
  apply FINDOM in BB. desf.
  { apply INJ in BB; subst. clear -LT. lia. }
  apply NN with (m:=m).
  { lia. }
  split; auto.
  intros HH. apply INJ in HH. desf.
Unshelve. apply 0.
Qed.

Theorem nat_ind_lt (P : nat -> Prop)
        (HPi : forall n, (forall m, m < n -> P m) -> P n) :
  forall n, P n.
Proof using.
  set (Q n := forall m, m <= n -> P m).
  assert (forall n, Q n) as HH.
  2: { ins. apply (HH n). lia. }
  ins. induction n.
  { unfold Q. ins. inv H. apply HPi. ins. inv H0. }
  unfold Q in *. ins.
  apply Lt.le_lt_or_eq in H.
  destruct H as [Hl | Heq].
  { unfold lt in Hl. apply le_S_n in Hl. by apply IHn. }
  rewrite Heq. apply HPi. ins.
  apply le_S_n in H. by apply IHn.
Qed.

Tactic Notation "destruct_seq" constr(x)
       "as" "[" ident(y) ident(z) "]" :=
  apply seq_eqv_l in x; destruct x as [y x];
  apply seq_eqv_r in x; destruct x as [x z].

Tactic Notation "destruct_seq_l" constr(x)
       "as" ident(y) :=
  apply seq_eqv_l in x; destruct x as [y x].

Tactic Notation "destruct_seq_r" constr(x)
       "as" ident(y) :=
  apply seq_eqv_r in x; destruct x as [x y].

Section Props.
Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'NTid_' t" := (fun x => tid x <> t) (at level 1).

Lemma ntid_tid_set_inter s thread :
  s ⊆₁ s ∩₁ NTid_ thread ∪₁ s ∩₁ Tid_ thread.
Proof using.
  ins.
  rewrite <- set_inter_union_r.
  unfolder. ins. splits; auto.
  destruct (classic (tid x = thread)); eauto.
Qed.
End Props.

Lemma dom_rel_to_cond {A} r (s t : A -> Prop) :
  dom_rel (r ⨾ ⦗t⦘) ⊆₁ s -> t ⊆₁ dom_cond r s.
Proof using.
  unfold dom_cond; unfolder.
  intro H; ins; desf; eapply H; eauto.
Qed.

Lemma dom_cond_to_rel {A} r (s t : A -> Prop) :
  t ⊆₁ dom_cond r s -> dom_rel (r ⨾ ⦗t⦘) ⊆₁ s.
Proof using.
  unfold dom_cond; unfolder.
  intro H; ins; desf; eapply H; eauto.
Qed.

Lemma set_extensionality {A} (s s' : A -> Prop)
      (IN : s ≡₁ s') :
  s = s'.
Proof using.
  ins; extensionality x.
  apply propositional_extensionality.
  split; apply IN.
Qed.

Lemma eqv_rel_alt {A: Type} (S: A -> Prop):
  ⦗S⦘ ≡ S × S ∩ eq.
Proof using. basic_solver. Qed.

Lemma doma_alt {A: Type} (r: relation A) (d: A -> Prop):
  doma r d <-> dom_rel r ⊆₁ d.
Proof using. unfolder. split; ins; basic_solver. Qed.

Lemma map_rel_seq_insert_exact {A B: Type} (r1 r2: relation B)
      (f: A -> B) (d: A -> Prop)
      (SUR_D: forall b, exists a, f a = b /\ d a):
  f ↓ (r1 ⨾ r2) ⊆ f ↓ r1 ⨾ ⦗d⦘ ⨾ f ↓ r2.
Proof using.
  unfolder. ins. desc.
  specialize (SUR_D z). desc. eexists. splits; eauto; congruence.
Qed.

Lemma rel_map_bunionC {A B C: Type} (f: A -> B)
      (cdom: C -> Prop) (ss: C -> relation B):
  f ↓ (⋃ c ∈ cdom, ss c) ≡ (⋃ c ∈ cdom, f ↓ (ss c)).
Proof using. basic_solver. Qed.

Lemma dom_rel_bunion {B C: Type}
      (cdom: C -> Prop) (ss: C -> relation B):
  dom_rel (⋃ c ∈ cdom, ss c) ≡₁ (⋃₁ c ∈ cdom, dom_rel (ss c)).
Proof using. basic_solver. Qed.

Lemma restr_rel_seq_same {A: Type} (r1 r2: relation A) (d: A -> Prop)
      (DOMB1: domb (⦗d⦘ ⨾ r1) d):
  restr_rel d (r1 ⨾ r2) ≡ restr_rel d r1 ⨾ restr_rel d r2.
Proof using.
  split; [| apply restr_seq].
  unfolder. unfolder in DOMB1. ins. desc.
  eexists. splits; eauto.
Qed.

Lemma set_subset_inter_exact {A: Type} (s s': A -> Prop):
  s ⊆₁ s' <-> s ⊆₁ s ∩₁ s'.
Proof using.
  split; [basic_solver| ]. ins.
  red. ins. by apply H.
Qed.

Lemma set_collect_map_ext [A B : Type] [f : A -> B] [d : B -> Prop]
      (SUR: forall b, exists a, f a = b):
  f ↑₁ (f ↓₁ d) ≡₁ d.
Proof using.
  ins. split; [apply set_collect_map| ].
  unfolder. ins.
  specialize (SUR x) as [a Fa]. exists a. split; congruence.
Qed.

Lemma restr_rel_cross_inter {A: Type} (d1 d2 d: A -> Prop):
  (d1 ∩₁ d) × (d2 ∩₁ d) ≡ restr_rel d (d1 × d2).
Proof using. basic_solver. Qed.

Global Add Parametric Morphism
       {A: Type} (r: relation (A -> Prop)):
  r with signature
       @set_equiv A ==> @set_equiv A ==> iff as set_equiv_rel_more.
Proof using. ins. apply set_extensionality in H, H0. by subst. Qed.

Lemma functional_codom {A: Type} (r: relation A) (a: A)
      (FUN: functional r)
      (DOMa: dom_rel r a):
  exists a', codom_rel (⦗eq a⦘ ⨾ r) ≡₁ eq a'.
Proof using.
  destruct DOMa as [a' Raa']. exists a'. split; [| basic_solver].
  intros x [a_ Ra_x%seq_eqv_l]. desc. subst.
  eapply FUN; eauto.
Qed.

Lemma set_eq_helper {A: Type} (s1 s2: A -> Prop) (EQ: s1 = s2):
  s1 ≡₁ s2.
Proof using. by rewrite EQ. Qed.

Lemma set_minus_disjoint {A: Type} (s1 s2: A -> Prop)
      (DISJ: set_disjoint s1 s2):
  s1 \₁ s2 ≡₁ s1.
Proof using. basic_solver. Qed.

Definition set_pair {A B} (s : A -> Prop) (t : B -> Prop) : A * B -> Prop :=
  fun ab =>
    match ab with
    | (a, b) => s a /\ t b
    end.
Global Notation "s <*> t" := (set_pair s t) (at level 40, left associativity).

Lemma set_pair_alt {A B: Type} (Sa: A -> Prop) (Sb: B -> Prop ):
  Sa <*> Sb ≡₁ (fst ↓₁ Sa) ∩₁ (snd ↓₁ Sb).
Proof using. unfold set_pair. basic_solver. Qed.

Global Add Parametric Morphism {A B: Type}: (@set_pair A B) with signature
       @set_equiv A ==> @set_equiv B ==> @set_equiv (A * B) as set_pair_more.
Proof using.
  ins. rewrite !set_pair_alt. rewrite H, H0. basic_solver.
Qed.

Global Add Parametric Morphism {A B: Type}: (@set_pair A B) with signature
       @set_subset A ==> @set_subset B ==> @set_subset (A * B) as set_pair_mori.
Proof using.
  ins. rewrite !set_pair_alt. rewrite H, H0. basic_solver.
Qed.

Lemma set_pair_union_l {A B} (s s' : A -> Prop) (p : B -> Prop) :
  (s ∪₁ s') <*> p ≡₁ s <*> p ∪₁ s' <*> p.
Proof using.
  clear.
  unfold set_pair.
  split.
  all: unfolder; ins.
  all: do 2 desf; eauto.
Qed.

Lemma set_pair_union_r {A B} (s : A -> Prop) (p p' : B -> Prop) :
  s <*> (p ∪₁ p') ≡₁ s <*> p ∪₁ s <*> p'.
Proof using.
  clear.
  unfold set_pair.
  split.
  all: unfolder; ins.
  all: do 2 desf; eauto.
Qed.

Lemma acyclic_transp {A: Type} (r: relation A)
      (AC: acyclic r):
  acyclic (transp r).
Proof using. red. rewrite <- transp_ct. vauto. Qed.

Lemma not_wf_inf_decr_enum {A: Type} (r: relation A)
      (NWF: ~ well_founded r):
  exists (f: nat -> A), forall i, r (f (i + 1)) (f i).
Proof using.
  contra DECR. destruct NWF.
  apply Classical_Wf.DSP_implies_WF. red. apply not_ex_not_all.
  intros [f DECR']. destruct DECR. exists f.
  ins. contra Nri. destruct DECR'. exists i. by rewrite <- PeanoNat.Nat.add_1_r.
Qed.

Lemma In_gt_list_max (l: list nat) (n: nat)
      (GT_MAX: n > list_max l):
  ~ In n l.
Proof using.
  intros IN.
  forward eapply (list_max_le l (list_max l)) as [IMPL _].
  specialize_full IMPL; [lia| ].
  eapply Forall_in in IMPL; eauto. lia.
Qed.

Lemma excluded_middle_or (A B: Prop)
      (OR: A \/ B):
  A \/ (~ A) /\ B.
Proof using. tauto. Qed.

Ltac liaW no := destruct no; [done| ins; lia].

Lemma dom_cond_alt {A : Type} (r : relation A) (d : A -> Prop):
  dom_cond r d ≡₁ (⋃₁ e ∈ (fun e_ => dom_rel (r ⨾ ⦗eq e_⦘) ⊆₁ d), eq e).
Proof using. unfold dom_cond. basic_solver 10. Qed.

Lemma dom_rel_union_r1 {A: Type} (S1 S2: A -> Prop) (r: relation A)
      (NOR2: ⦗S2⦘ ⨾ r ⊆ ∅₂)
      (DOM: dom_rel r ⊆₁ S1 ∪₁ S2):
  dom_rel r ⊆₁ S1.
Proof using.
  red. intros x D.
  specialize (@DOM x D). destruct DOM; auto.
  red in D. desc.
  edestruct NOR2; basic_solver 10.
Qed.

Lemma doma_map_rel {A B: Type} (r: relation A) (S: A -> Prop) (f: B -> A)
      (DOMA: doma r S):
  doma (f ↓ r) (f ↓₁ S).
Proof using.
  unfolder. ins. eapply DOMA; eauto.
Qed.

Lemma domb_map_rel {A B: Type} (r: relation A) (S: A -> Prop) (f: B -> A)
      (DOMB: domb r S):
  domb (f ↓ r) (f ↓₁ S).
Proof using.
  unfolder. ins. eapply DOMB; eauto.
Qed.

Lemma bunion_set_bunion {A B: Type} (ss: B -> A -> Prop):
  (⋃ x, ⦗ss x⦘) ≡ (⦗⋃₁ x, ss x⦘).
Proof using. basic_solver. Qed.

Lemma bunion_more_equiv {A B: Type} (As1 As2: A -> Prop) (ABB1 ABB2: A -> relation B)
      (EQA: As1 ≡₁ As2) (EQB: forall a (AS: As1 a), ABB1 a ≡ ABB2 a):
  (⋃ a ∈ As1, ABB1 a) ≡ (⋃ a ∈ As2, ABB2 a).
Proof using.
  unfolder. split; ins; desc; exists a.
  all: splits; [apply EQA | apply EQB]; auto.
  by apply EQA.
Qed.

Lemma set_compl_set_mapC {A B: Type} (d: B -> Prop) (f: A -> B):
  set_compl (f ↓₁ d) ≡₁  (f ↓₁ set_compl d).
Proof using. basic_solver. Qed.


Require Import Common.
Require Import Computation.Core.

(** General Lemmas about the parametric morphism behavior of
    [computes_to], [refine], and [refineEquiv]. *)

Add Parametric Relation A
: (Comp A) (@refine A)
  reflexivity proved by reflexivity
  transitivity proved by transitivity
    as refine_rel.

Add Parametric Relation A
: (Comp A) (@refineEquiv A)
  reflexivity proved by reflexivity
  symmetry proved by symmetry
  transitivity proved by transitivity
    as refineEquiv_rel.

Local Ltac t := unfold impl; intros; repeat (eapply_hyp || etransitivity).

Add Parametric Morphism A
: (@refine A)
  with signature
  (@refine A) --> (@refine A) ++> impl
    as refine_refine.
Proof. t. Qed.

Add Parametric Morphism A
: (@refine A)
  with signature
  (@refineEquiv A) --> (@refineEquiv A) ++> impl
    as refine_refineEquiv.
Proof. t. Qed.

Hint Constructors computes_to.

Add Parametric Morphism A B
: (@Bind A B)
    with signature
    (@refine A)
      ==> (pointwise_relation _ (@refine B))
      ==> (@refine B)
      as refine_bind.
Proof.
  simpl; intros.
  unfold pointwise_relation, refine in *; simpl in *.
  intros.
  inversion_by computes_to_inv.
  eauto.
Qed.

Add Parametric Morphism A B
: (@Bind A B)
    with signature
    (@refineEquiv A)
      ==> (pointwise_relation _ (@refineEquiv B))
      ==> (@refineEquiv B)
      as refineEquiv_bind.
Proof.
  idtac.
  simpl; intros.
  unfold pointwise_relation, refineEquiv, refine in *.
  split_and; simpl in *.
  split; intros;
  inversion_by computes_to_inv;
  eauto.
Qed.

Add Parametric Morphism A
: (@Pick A)
    with signature
    (pointwise_relation _ (flip impl))
      ==> (@refine A)
      as refine_flip_impl_Pick.
Proof.
  simpl; intros.
  unfold pointwise_relation, refine, impl in *; simpl in *.
  intros.
  inversion_by computes_to_inv.
  eauto.
Qed.

Add Parametric Morphism A
: (@Pick A)
    with signature
    (pointwise_relation _ impl)
      ==> (flip (@refine A))
      as refine_impl_flip_Pick.
Proof.
  simpl; intros.
  unfold pointwise_relation, refine, impl in *; simpl in *.
  intros.
  inversion_by computes_to_inv.
  eauto.
Qed.

(* We have to define a wrapper for if then else in
 order for it to play nicely with setoid_rewriting. *)
Definition If_Then_Else {A}
           (c : bool)
           (t e : A) :=
  if c then t else e.

Add Parametric Morphism A (c : bool)
: (If_Then_Else c)
    with signature
      (@refine A ==> @refine A ==> @refine A )
      as refine_If_Then_Else.
Proof.
  unfold If_Then_Else; intros.
  destruct c; eassumption.
Qed.

Notation "'If' c 'Then' t 'Else' e" :=
  (If_Then_Else c t e)
    (at level 70).

Definition If_Opt_Then_Else {A B}
           (c : option A)
           (t : A -> B)
           (e : B) :=
  match c with
    | Some a => t a
    | None => e
  end.

Add Parametric Morphism A B (c : option A)
: (@If_Opt_Then_Else A (Comp B) c)
    with signature
    ((pointwise_relation A (@refine B))
       ==> @refine B
       ==> @refine B )
      as refine_If_Opt_Then_Else.
Proof.
  unfold If_Opt_Then_Else; intros.
  destruct c; eauto.
Qed.

Notation "'Ifopt' c 'as' c' 'Then' t 'Else' e" :=
  (If_Opt_Then_Else c (fun c' => t) e)
    (at level 70).

Add Parametric Morphism A
: (@Pick A)
    with signature
    (pointwise_relation _ iff)
      ==> (@refineEquiv A)
      as refineEquiv_iff_Pick.
Proof.
  simpl; intros.
  unfold pointwise_relation, refine in *; simpl in *.
  split_iff.
  change (pointwise_relation A impl y x) in H1.
  change (pointwise_relation A impl x y) in H0.
  split;
    intros;
    setoid_rewrite_hyp';
    reflexivity.
Qed.

Add Parametric Morphism A : (@computes_to A)
    with signature
    @refine A --> @eq A ==> impl
      as refine_computes_to_mor.
Proof.
  unfold refine, impl in *; intros; auto.
Qed.

Add Parametric Morphism A B
: (fun P => refine { x : A | exists y : B x, P x y })
    with signature
    forall_relation (fun _ => pointwise_relation _ impl) ==> @refine A ==> impl
      as refine_exists_mor.
Proof.
  unfold pointwise_relation, impl, refine in *.
  intros.
  specialize_all_ways.
  repeat match goal with
           | [ H : computes_to _ _ |- _ ] => apply computes_to_inv in H
         end.
  constructor.
  destruct_head ex.
  eauto.
Qed.

Instance refine_refineEquiv_subrelation A
: subrelation (@refineEquiv A) (@refine A).
Proof.
  intros ? ? [? ?]; assumption.
Qed.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(** printing Lim %\ensuremath{\lim}% *)

Require Export CoRN.algebra.COrdCauchy.

(**
* Definition of the notion of reals
The reals are defined as a Cauchy-closed Archimedean constructive
ordered field in which we have a maximum function. The maximum
function is definable, using countable choice, but in a rather tricky
way. Cauchy completeness is stated by assuming a function [lim]
that returns a real number for every Cauchy sequence together with a
proof that this number is the limit.
*)

(* Begin_SpecReals *)

Record is_CReals (R : COrdField) (lim : CauchySeq R -> R) : CProp :=
  {ax_Lim  : forall s : CauchySeq R, SeqLimit s (lim s);
   ax_Arch : forall x : R, {n : nat | x [<=] nring n}}.

Record CReals : Type :=
  {crl_crr   :> COrdField;
   crl_lim   :  CauchySeq crl_crr -> crl_crr;
   crl_proof :  is_CReals crl_crr crl_lim}.

(* End_SpecReals *)

Definition Lim : forall IR : CReals, CauchySeq IR -> IR := crl_lim.

Arguments Lim [IR].


(* DEC1 language development.
   Paolo Torrini, wtih David Nowak
   Universite' Lille-1 - CRIStAL-CNRS
*)
(* induction principle for the typing relations *)

Require Export Basics.
Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.

Require Export EnvLibA.
Require Export RelLibA.
Require Export StaticSemA.

Import ListNotations.

Module TRInduct (IdT: IdModType) <: IdModType.

Module StaticI := Static IdT.
Export StaticI.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition Loc_PI := IdT.Loc_PI.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Lemma ExpTyping_gen_str_rect : forall

(* properties *)

         (PPF : forall (f : Fun) (ft : FTyp),
                  FunTyping f ft -> Type)

         (PPQ : forall (ftenv : funTC) (fenv : funEnv)
                       (q : QFun) (ft : FTyp),
                  QFunTyping ftenv fenv q ft -> Type)

         (PPE : forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
                       (e : Exp) (v : VTyp),
                  ExpTyping ftenv tenv fenv e v -> Type)

         (PPP : forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
                       (ps : Prms) (pt : PTyp),
                  PrmsTyping ftenv tenv fenv ps pt -> Type)

         (SSL : forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
                       (es: list Exp) (ts: list VTyp),
		  Forall2T (ExpTyping ftenv tenv fenv) es ts -> Type)

         (SSA : forall (ftenv : funTC) (fenv: funEnv),
		  MatchEnvsT FunTyping fenv ftenv -> Type)

         (SSB : forall (ftenv : funTC) (fenv: funEnv)
                       (x:Id) (f: Fun) (ft:FTyp),
		  MatchEnvs2BT FunTyping x f ft fenv ftenv -> Type),

(** SSL cases **)

       (forall (ftenv : funTC) (tenv : valTC) (fenv: funEnv),
        SSL ftenv tenv fenv nil nil
           (Forall2_nilT (ExpTyping ftenv tenv fenv))) ->

       (forall (ftenv : funTC) (tenv : valTC) (fenv: funEnv)
               (es : list Exp) (ts : list VTyp)
               (e: Exp) (t: VTyp)
               (m1: ExpTyping ftenv tenv fenv e t)
               (m2 : Forall2T (ExpTyping ftenv tenv fenv) es ts),
        SSL ftenv tenv fenv es ts m2 ->
	PPE ftenv tenv fenv e t m1 ->
	SSL ftenv tenv fenv (e::es) (t::ts)
         (Forall2_consT (ExpTyping ftenv tenv fenv) e t es ts m1 m2)) ->

(** SSA cases **)

       (SSA nil nil (MatchEnvs_NilT FunTyping)) ->

       (forall (ftenv : funTC) (fenv : funEnv)
               (x:Id) (f: Fun) (t: FTyp)
               (m1: FunTyping f t)
               (m2 : MatchEnvsT FunTyping fenv ftenv),
        SSA ftenv fenv m2 ->
	PPF f t m1 ->
        SSA ((x,t)::ftenv) ((x,f)::fenv)
            (MatchEnvs_ConsT FunTyping fenv ftenv x f t m1 m2)) ->

(** SSB cases **)

       (forall (ftenv ftenv0 ftenv1: funTC)
               (fenv fenv0 fenv1: funEnv)
               (x:Id) (f: Fun) (t: FTyp)
               (k: FunTyping f t)
               (m0 : MatchEnvsT FunTyping fenv0 ftenv0)
               (m1 : MatchEnvsT FunTyping fenv1 ftenv1)
               (h1 : findE ftenv0 x = None)
               (h2 : fenv = fenv0 ++ ((x,f)::fenv1))
               (h3 : ftenv = ftenv0 ++ ((x,t)::ftenv1)),
        SSA ftenv0 fenv0 m0 ->
        SSA ftenv1 fenv1 m1 ->
        PPF f t k ->
        SSB ftenv fenv x f t
           (MatchEnvs2B_splitT FunTyping x f t
               fenv ftenv fenv0 ftenv0 fenv1 ftenv1 k m0 m1 h1 h2 h3)) ->

(** PPF cases *)

(* FunZ *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
          (e0 e1 : Exp) (x : Id) (t : VTyp)
          (m : MatchEnvsT FunTyping fenv ftenv)
          (k : ExpTyping ftenv tenv fenv e0 t),
        PPE ftenv tenv fenv e0 t k ->
        PPF (FC fenv tenv e0 e1 x 0) (FT tenv t)
            (FunZ_Typing ftenv tenv fenv e0 e1 x t m k)) ->

(* FunS *)
       (forall (ftenv : funTC) (tenv : valTC)
               (fenv : funEnv)
               (e0 e1 : Exp) (x : Id)
               (n : nat) (t : VTyp),
        let ftenv' := (x, FT tenv t) :: ftenv in
        let fenv' := (x, FC fenv tenv e0 e1 x n) :: fenv in
        forall (m : MatchEnvsT FunTyping fenv ftenv)
               (k1 : ExpTyping ftenv' tenv fenv' e1 t)
               (k2 : FunTyping (FC fenv tenv e0 e1 x n) (FT tenv t)),
        PPE ftenv' tenv fenv' e1 t k1 ->
        PPF (FC fenv tenv e0 e1 x n) (FT tenv t) k2 ->
        PPF (FC fenv tenv e0 e1 x (S n)) (FT tenv t)
                (FunS_Typing ftenv tenv fenv
                                      e0 e1 x n t m k1 k2)) ->

(** PPQ cases *)

(* QF *)
       (forall (ftenv : funTC) (fenv : funEnv)
               (f : Fun) (ft : FTyp)
               (k : FunTyping f ft),
        PPF f ft k ->
        PPQ ftenv fenv (QF f) ft (QF_Typing ftenv fenv f ft k)) ->

(* FVar  *)
       (forall (ftenv : funTC) (fenv : funEnv) (x : Id)
               (f : Fun) (ft : FTyp)
               (m : MatchEnvs2BT FunTyping x f ft fenv ftenv),
        SSB ftenv fenv x f ft m ->
        PPQ ftenv fenv (FVar x) ft (FVar_Typing ftenv fenv x f ft m)) ->

(** PPE cases *)

(* Modify *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (T1 T2 : Type) (VT1 : ValTyp T1) (VT2 : ValTyp T2)
               (XF: XFun T1 T2) (q : QValue)
               (k : QValueTyping tenv q (vtyp T1)),
        PPE ftenv tenv fenv (Modify T1 T2 VT1 VT2 XF q) (vtyp T2)
              (Modify_Typing ftenv tenv fenv T1 T2 VT1 VT2 XF q k)) ->

(* Return *)
       (forall (G : Tag)
               (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (q : QValue) (t : VTyp)
               (k : QValueTyping tenv q t),
        PPE ftenv tenv fenv (Return G q) t
            (Return_Typing G ftenv tenv fenv q t k)) ->

(* BindN *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (e1 e2 : Exp) (t1 t2 : VTyp)
               (k1 : ExpTyping ftenv tenv fenv e1 t1)
               (k2 : ExpTyping ftenv tenv fenv e2 t2),
        PPE ftenv tenv fenv e1 t1 k1 ->
        PPE ftenv tenv fenv e2 t2 k2 ->
        PPE ftenv tenv fenv (BindN e1 e2) t2
            (BindN_Typing ftenv tenv fenv e1 e2 t1 t2 k1 k2)) ->

(* BindS *)
       (forall (ftenv : funTC) (tenv : valTC)
               (fenv : funEnv) (x : Id) (e1 e2 : Exp) (t1 t2 : VTyp),
        let tenv' := (x, t1) :: tenv in
        forall (k1 : ExpTyping ftenv tenv fenv e1 t1)
               (k2 : ExpTyping ftenv tenv' fenv e2 t2),
        PPE ftenv tenv fenv e1 t1 k1 ->
        PPE ftenv tenv' fenv e2 t2 k2 ->
        PPE ftenv tenv fenv (BindS x e1 e2) t2
            (BindS_Typing ftenv tenv fenv x e1 e2 t1 t2 k1 k2)) ->

(* BindMS *)
       (forall (ftenv ftenvP ftenv' : funTC) (tenv tenvP tenv' : valTC)
               (fenv fenvP fenv' : funEnv) (envP : valEnv)
               (e : Exp) (t : VTyp)
               (k1 : EnvTyping envP tenvP)
               (m1 : MatchEnvsT FunTyping fenv ftenv)
               (m2 : MatchEnvsT FunTyping fenvP ftenvP)
               (h1: tenv' = tenvP ++ tenv)
               (h2: ftenv' = ftenvP ++ ftenv)
               (h3: fenv' = fenvP ++ fenv)
               (k2: ExpTyping ftenv' tenv' fenv' e t),
        PPE ftenv' tenv' fenv' e t k2 ->
        PPE ftenv tenv fenv (BindMS fenvP envP e) t
          (BindMS_Typing ftenv ftenvP ftenv' tenv tenvP tenv' fenv fenvP
             fenv' envP e t k1 m1 m2 h1 h2 h3 k2)) ->

(* Apply *)
       (forall (ftenv : funTC) (tenv fps : valTC) (fenv : funEnv)
               (q : QFun) (ps : Prms) (pt : PTyp) (t : VTyp)
               (h : pt = env2ptyp fps)
               (m : MatchEnvsT FunTyping fenv ftenv)
               (k1 : QFunTyping ftenv fenv q (FT fps t))
               (k2 : PrmsTyping ftenv tenv fenv ps pt),
        PPQ ftenv fenv q (FT fps t) k1 ->
        PPP ftenv tenv fenv ps pt k2 ->
        PPE ftenv tenv fenv (Apply q ps) t
            (Apply_Typing ftenv tenv fps fenv q ps pt t h m k1 k2)) ->

(* Val *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (v : Value) (t : VTyp)
               (k : ValueTyping v t),
          PPE ftenv tenv fenv (Val v) t
              (Val_Typing ftenv tenv fenv v t k)) ->

(* IfThenElse *)

       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
          (e1 e2 e3 : Exp) (t : VTyp)
          (k1 : ExpTyping ftenv tenv fenv e1 Bool)
          (k2 : ExpTyping ftenv tenv fenv e2 t)
          (k3 : ExpTyping ftenv tenv fenv e3 t),
        PPE ftenv tenv fenv e1 Bool k1 ->
        PPE ftenv tenv fenv e2 t k2 ->
        PPE ftenv tenv fenv e3 t k3 ->
        PPE ftenv tenv fenv (IfThenElse e1 e2 e3) t
           (IfThenElse_Typing ftenv tenv fenv e1 e2 e3 t k1 k2 k3)) ->

(** PPP cases *)

(* PS *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (es : list Exp) (ts : list VTyp)
               (m : Forall2T (ExpTyping ftenv tenv fenv) es ts),
        SSL ftenv tenv fenv es ts m ->
        PPP ftenv tenv fenv (PS es) (PT ts)
            (PS_Typing ftenv tenv fenv es ts m)) ->

(** PPE conclusion *)

       forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
              (e : Exp) (v : VTyp)
              (k : ExpTyping ftenv tenv fenv e v),
        PPE ftenv tenv fenv e v k.

Proof.
  intros PPF PPQ PPE PPP SSL SSA SSB.
  intros.
  revert ftenv tenv fenv e v k.

  fix HP_E 6 with
  (HP_F (f : Fun) (ft : FTyp) (k: FunTyping f ft) {struct k}:
                                           PPF f ft k)
  (HP_Q (ftenv : funTC) (fenv: funEnv) (h : QFun) (ft : FTyp)                           (k: QFunTyping ftenv fenv h ft) {struct k}:
                                           PPQ ftenv fenv h ft k)
  (HP_P (ftenv : funTC) (tenv : valTC) (fenv: funEnv) (ps : Prms) (ts : PTyp)
       (k: PrmsTyping ftenv tenv fenv ps ts) {struct k}:
                                           PPP ftenv tenv fenv ps ts k).

(* PPE *)
- intros.
  destruct k.
  + apply X8.
  + apply X9.
  + apply X10.
    * apply HP_E.
    * apply HP_E.
  + apply X11.
    * apply HP_E.
    * apply HP_E.
  + apply X12.
    * apply HP_E.
  + apply X13.
    * apply HP_Q.
    * apply HP_P.
  + apply X14.
  + apply X15.
    * apply HP_E.
    * apply HP_E.
    * apply HP_E.
(* PPF *)
- intros.
  destruct k.
  + apply X4.
    apply HP_E.
  + apply X5.
    apply HP_E.
    apply HP_F.
(* PPQ *)
- intros.
  destruct k.
  + apply X6.
    apply HP_F.
  + apply X7.
    destruct m.
    * apply X3.
      {- revert m e.
         subst ls5 ls6.
         revert ls2 ls1.
         fix HP_QA 3.
         intros.
         destruct m.
         + apply X1.
         + apply X2.
           * apply HP_QA.
             {- inversion e; subst.
                destruct (IdT.IdEqDec x k).
                + inversion H0.
                + reflexivity.
             }
           * apply HP_F.
      }
      {- revert m0 e.
         subst ls5 ls6.
         revert ls4 ls3.
         fix HP_QA 3.
         intros.
         destruct m0.
         + apply X1.
         + apply X2.
           * apply HP_QA.
             {- exact e. }
           * apply HP_F.
      }
      {- apply HP_F. }
(* PPP *)
- intros.
  destruct k.
  apply X16.
  revert f.
  revert es ts.
  fix HP_QL 3.
  intros.
  destruct f.
  + apply X.
  + apply X0.
    * apply HP_QL.
    * apply HP_E.
Defined.

(*********************************************************************)

Definition Par_SSL
  (PE : forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
                       (e : Exp) (v : VTyp),
                  ExpTyping ftenv tenv fenv e v -> Type) :=
  fun (ftenv : funTC) (tenv : valTC) (fenv: funEnv)
      (es: list Exp) (ts: list VTyp)
      (m:  Forall2T (ExpTyping ftenv tenv fenv) es ts) =>
   Forall3AT (ExpTyping ftenv tenv fenv)
             (fun (e: Exp) (t: VTyp) (k: ExpTyping ftenv tenv fenv e t) =>
                 PE ftenv tenv fenv e t k)
             es ts.

Definition Par_SSA
  (PF : forall (f : Fun) (ft : FTyp), FunTyping f ft -> Type) :=
  fun (ftenv : funTC) (fenv: funEnv)
      (m: MatchEnvsT FunTyping fenv ftenv) =>
   Forall3T FunTyping
            (fun (f: Fun) (ft: FTyp) (k: FunTyping f ft) => PF f ft k)
            fenv ftenv.

Definition Par_SSB
           (PF : forall (f : Fun) (ft : FTyp), FunTyping f ft -> Type) :=
  fun (ftenv : funTC) (fenv: funEnv) (x: Id) (f: Fun) (ft: FTyp)
      (mb: MatchEnvs2BT FunTyping x f ft fenv ftenv) =>
        @Forall2BT Id Fun FTyp IdEq FunTyping PF
                   (fun (fenv: funEnv) (ftenv : funTC)
                        (ma: MatchEnvsT FunTyping fenv ftenv) =>
                      Par_SSA PF ftenv fenv ma)
                   x f ft fenv ftenv.

Definition ExpTyping_str_rect PPF PPQ PPE PPP :=
  ExpTyping_gen_str_rect PPF PPQ PPE PPP
       (Par_SSL PPE) (Par_SSA PPF) (Par_SSB PPF).

(***********************************************************************)

Lemma FunTyping_gen_str_rect : forall

(* properties *)

         (PPF : forall (f : Fun) (ft : FTyp),
                  FunTyping f ft -> Type)

         (PPQ : forall (ftenv : funTC) (fenv : funEnv)
                       (q : QFun) (ft : FTyp),
                  QFunTyping ftenv fenv q ft -> Type)

         (PPE : forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
                       (e : Exp) (v : VTyp),
                  ExpTyping ftenv tenv fenv e v -> Type)

         (PPP : forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
                       (ps : Prms) (pt : PTyp),
                  PrmsTyping ftenv tenv fenv ps pt -> Type)

         (SSL : forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
                       (es: list Exp) (ts: list VTyp),
		  Forall2T (ExpTyping ftenv tenv fenv) es ts -> Type)

         (SSA : forall (ftenv : funTC) (fenv: funEnv),
		  MatchEnvsT FunTyping fenv ftenv -> Type)

         (SSB : forall (ftenv : funTC) (fenv: funEnv)
                       (x:Id) (f: Fun) (ft:FTyp),
		  MatchEnvs2BT FunTyping x f ft fenv ftenv -> Type),

(** SSL cases **)

       (forall (ftenv : funTC) (tenv : valTC) (fenv: funEnv),
        SSL ftenv tenv fenv nil nil
           (Forall2_nilT (ExpTyping ftenv tenv fenv))) ->

       (forall (ftenv : funTC) (tenv : valTC) (fenv: funEnv)
               (es : list Exp) (ts : list VTyp)
               (e: Exp) (t: VTyp)
               (m1: ExpTyping ftenv tenv fenv e t)
               (m2 : Forall2T (ExpTyping ftenv tenv fenv) es ts),
        SSL ftenv tenv fenv es ts m2 ->
	PPE ftenv tenv fenv e t m1 ->
	SSL ftenv tenv fenv (e::es) (t::ts)
         (Forall2_consT (ExpTyping ftenv tenv fenv) e t es ts m1 m2)) ->

(** SSA cases **)

       (SSA nil nil (MatchEnvs_NilT FunTyping)) ->

       (forall (ftenv : funTC) (fenv : funEnv)
               (x:Id) (f: Fun) (t: FTyp)
               (m1: FunTyping f t)
               (m2 : MatchEnvsT FunTyping fenv ftenv),
        SSA ftenv fenv m2 ->
	PPF f t m1 ->
        SSA ((x,t)::ftenv) ((x,f)::fenv)
            (MatchEnvs_ConsT FunTyping fenv ftenv x f t m1 m2)) ->

(** SSB cases **)

       (forall (ftenv ftenv0 ftenv1: funTC)
               (fenv fenv0 fenv1: funEnv)
               (x:Id) (f: Fun) (t: FTyp)
               (k: FunTyping f t)
               (m0 : MatchEnvsT FunTyping fenv0 ftenv0)
               (m1 : MatchEnvsT FunTyping fenv1 ftenv1)
               (h1 : findE ftenv0 x = None)
               (h2 : fenv = fenv0 ++ ((x,f)::fenv1))
               (h3 : ftenv = ftenv0 ++ ((x,t)::ftenv1)),
        SSA ftenv0 fenv0 m0 ->
        SSA ftenv1 fenv1 m1 ->
        PPF f t k ->
        SSB ftenv fenv x f t
           (MatchEnvs2B_splitT FunTyping x f t
               fenv ftenv fenv0 ftenv0 fenv1 ftenv1 k m0 m1 h1 h2 h3)) ->

(** PPF cases *)

(* FunZ *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
          (e0 e1 : Exp) (x : Id) (t : VTyp)
          (m : MatchEnvsT FunTyping fenv ftenv)
          (k : ExpTyping ftenv tenv fenv e0 t),
        PPE ftenv tenv fenv e0 t k ->
        PPF (FC fenv tenv e0 e1 x 0) (FT tenv t)
            (FunZ_Typing ftenv tenv fenv e0 e1 x t m k)) ->

(* FunS *)
       (forall (ftenv : funTC) (tenv : valTC)
               (fenv : funEnv)
               (e0 e1 : Exp) (x : Id)
               (n : nat) (t : VTyp),
        let ftenv' := (x, FT tenv t) :: ftenv in
        let fenv' := (x, FC fenv tenv e0 e1 x n) :: fenv in
        forall (m : MatchEnvsT FunTyping fenv ftenv)
               (k1 : ExpTyping ftenv' tenv fenv' e1 t)
               (k2 : FunTyping (FC fenv tenv e0 e1 x n) (FT tenv t)),
        PPE ftenv' tenv fenv' e1 t k1 ->
        PPF (FC fenv tenv e0 e1 x n) (FT tenv t) k2 ->
        PPF (FC fenv tenv e0 e1 x (S n)) (FT tenv t)
                (FunS_Typing ftenv tenv fenv
                                      e0 e1 x n t m k1 k2)) ->

(** PPQ cases *)

(* QF *)
       (forall (ftenv : funTC) (fenv : funEnv)
               (f : Fun) (ft : FTyp)
               (k : FunTyping f ft),
        PPF f ft k ->
        PPQ ftenv fenv (QF f) ft (QF_Typing ftenv fenv f ft k)) ->

(* FVar  *)
       (forall (ftenv : funTC) (fenv : funEnv) (x : Id)
               (f : Fun) (ft : FTyp)
               (m : MatchEnvs2BT FunTyping x f ft fenv ftenv),
        SSB ftenv fenv x f ft m ->
        PPQ ftenv fenv (FVar x) ft (FVar_Typing ftenv fenv x f ft m)) ->

(** PPE cases *)

(* Modify *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (T1 T2 : Type) (VT1 : ValTyp T1) (VT2 : ValTyp T2)
               (XF: XFun T1 T2) (q : QValue)
               (k : QValueTyping tenv q (vtyp T1)),
        PPE ftenv tenv fenv (Modify T1 T2 VT1 VT2 XF q) (vtyp T2)
              (Modify_Typing ftenv tenv fenv T1 T2 VT1 VT2 XF q k)) ->

(* Return *)
       (forall (G : Tag)
               (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (q : QValue) (t : VTyp)
               (k : QValueTyping tenv q t),
        PPE ftenv tenv fenv (Return G q) t
            (Return_Typing G ftenv tenv fenv q t k)) ->

(* BindN *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (e1 e2 : Exp) (t1 t2 : VTyp)
               (k1 : ExpTyping ftenv tenv fenv e1 t1)
               (k2 : ExpTyping ftenv tenv fenv e2 t2),
        PPE ftenv tenv fenv e1 t1 k1 ->
        PPE ftenv tenv fenv e2 t2 k2 ->
        PPE ftenv tenv fenv (BindN e1 e2) t2
            (BindN_Typing ftenv tenv fenv e1 e2 t1 t2 k1 k2)) ->

(* BindS *)
       (forall (ftenv : funTC) (tenv : valTC)
               (fenv : funEnv) (x : Id) (e1 e2 : Exp) (t1 t2 : VTyp),
        let tenv' := (x, t1) :: tenv in
        forall (k1 : ExpTyping ftenv tenv fenv e1 t1)
               (k2 : ExpTyping ftenv tenv' fenv e2 t2),
        PPE ftenv tenv fenv e1 t1 k1 ->
        PPE ftenv tenv' fenv e2 t2 k2 ->
        PPE ftenv tenv fenv (BindS x e1 e2) t2
            (BindS_Typing ftenv tenv fenv x e1 e2 t1 t2 k1 k2)) ->

(* BindMS *)
       (forall (ftenv ftenvP ftenv' : funTC) (tenv tenvP tenv' : valTC)
               (fenv fenvP fenv' : funEnv) (envP : valEnv)
               (e : Exp) (t : VTyp)
               (k1 : EnvTyping envP tenvP)
               (m1 : MatchEnvsT FunTyping fenv ftenv)
               (m2 : MatchEnvsT FunTyping fenvP ftenvP)
               (h1: tenv' = tenvP ++ tenv)
               (h2: ftenv' = ftenvP ++ ftenv)
               (h3: fenv' = fenvP ++ fenv)
               (k2: ExpTyping ftenv' tenv' fenv' e t),
        PPE ftenv' tenv' fenv' e t k2 ->
        PPE ftenv tenv fenv (BindMS fenvP envP e) t
          (BindMS_Typing ftenv ftenvP ftenv' tenv tenvP tenv' fenv fenvP
             fenv' envP e t k1 m1 m2 h1 h2 h3 k2)) ->

(* Apply *)
       (forall (ftenv : funTC) (tenv fps : valTC) (fenv : funEnv)
               (q : QFun) (ps : Prms) (pt : PTyp) (t : VTyp)
               (h : pt = env2ptyp fps)
               (m : MatchEnvsT FunTyping fenv ftenv)
               (k1 : QFunTyping ftenv fenv q (FT fps t))
               (k2 : PrmsTyping ftenv tenv fenv ps pt),
        PPQ ftenv fenv q (FT fps t) k1 ->
        PPP ftenv tenv fenv ps pt k2 ->
        PPE ftenv tenv fenv (Apply q ps) t
            (Apply_Typing ftenv tenv fps fenv q ps pt t h m k1 k2)) ->

(* Val *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (v : Value) (t : VTyp)
               (k : ValueTyping v t),
          PPE ftenv tenv fenv (Val v) t
              (Val_Typing ftenv tenv fenv v t k)) ->

(* IfThenElse *)

       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
          (e1 e2 e3 : Exp) (t : VTyp)
          (k1 : ExpTyping ftenv tenv fenv e1 Bool)
          (k2 : ExpTyping ftenv tenv fenv e2 t)
          (k3 : ExpTyping ftenv tenv fenv e3 t),
        PPE ftenv tenv fenv e1 Bool k1 ->
        PPE ftenv tenv fenv e2 t k2 ->
        PPE ftenv tenv fenv e3 t k3 ->
        PPE ftenv tenv fenv (IfThenElse e1 e2 e3) t
           (IfThenElse_Typing ftenv tenv fenv e1 e2 e3 t k1 k2 k3)) ->

(** PPP cases *)

(* PS *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (es : list Exp) (ts : list VTyp)
               (m : Forall2T (ExpTyping ftenv tenv fenv) es ts),
        SSL ftenv tenv fenv es ts m ->
        PPP ftenv tenv fenv (PS es) (PT ts)
            (PS_Typing ftenv tenv fenv es ts m)) ->

(** PPF conclusion *)

       forall (f : Fun) (ft : FTyp)
              (k: FunTyping f ft),
        PPF f ft k.

Proof.
  intros PPF PPQ PPE PPP SSL SSA SSB.
  intros.
  revert f ft k.

  fix HP_F 3 with

  (HP_E (ftenv : funTC) (tenv : valTC) (fenv : funEnv) (e : Exp)
        (v : VTyp) (k: ExpTyping ftenv tenv fenv e v) {struct k}:
                                           PPE ftenv tenv fenv e v k)
  (HP_Q (ftenv : funTC) (fenv: funEnv) (h : QFun) (ft : FTyp)                           (k: QFunTyping ftenv fenv h ft) {struct k}:
                                           PPQ ftenv fenv h ft k)
  (HP_P (ftenv : funTC) (tenv : valTC) (fenv: funEnv) (ps : Prms) (ts : PTyp)
       (k: PrmsTyping ftenv tenv fenv ps ts) {struct k}:
                                           PPP ftenv tenv fenv ps ts k).

(* PPF *)
- intros.
  destruct k.
  + apply X4.
    apply HP_E.
  + apply X5.
    apply HP_E.
    apply HP_F.
(* PPE *)
- intros.
  destruct k.
  + apply X8.
  + apply X9.
  + apply X10.
    * apply HP_E.
    * apply HP_E.
  + apply X11.
    * apply HP_E.
    * apply HP_E.
  + apply X12.
    * apply HP_E.
  + apply X13.
    * apply HP_Q.
    * apply HP_P.
  + apply X14.
  + apply X15.
    * apply HP_E.
    * apply HP_E.
    * apply HP_E.
(* PPQ *)
- intros.
  destruct k.
  + apply X6.
    apply HP_F.
  + apply X7.
    destruct m.
    * apply X3.
      {- revert m e.
         subst ls5 ls6.
         revert ls2 ls1.
         fix HP_QA 3.
         intros.
         destruct m.
         + apply X1.
         + apply X2.
           * apply HP_QA.
             {- inversion e; subst.
                destruct (IdT.IdEqDec x k).
                + inversion H0.
                + reflexivity.
             }
           * apply HP_F.
      }
      {- revert m0 e.
         subst ls5 ls6.
         revert ls4 ls3.
         fix HP_QA 3.
         intros.
         destruct m0.
         + apply X1.
         + apply X2.
           * apply HP_QA.
             {- exact e. }
           * apply HP_F.
      }
      {- apply HP_F. }
(* PPP *)
- intros.
  destruct k.
  apply X16.
  revert f.
  revert es ts.
  fix HP_QL 3.
  intros.
  destruct f.
  + apply X.
  + apply X0.
    * apply HP_QL.
    * apply HP_E.
Defined.

Definition FunTyping_str_rect PPF PPQ PPE PPP :=
  FunTyping_gen_str_rect PPF PPQ PPE PPP
       (Par_SSL PPE) (Par_SSA PPF) (Par_SSB PPF).

(***********************************************************************)

Lemma QFunTyping_gen_str_rect : forall

(* properties *)

         (PPF : forall (f : Fun) (ft : FTyp),
                  FunTyping f ft -> Type)

         (PPQ : forall (ftenv : funTC) (fenv : funEnv)
                       (q : QFun) (ft : FTyp),
                  QFunTyping ftenv fenv q ft -> Type)

         (PPE : forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
                       (e : Exp) (v : VTyp),
                  ExpTyping ftenv tenv fenv e v -> Type)

         (PPP : forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
                       (ps : Prms) (pt : PTyp),
                  PrmsTyping ftenv tenv fenv ps pt -> Type)

         (SSL : forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
                       (es: list Exp) (ts: list VTyp),
		  Forall2T (ExpTyping ftenv tenv fenv) es ts -> Type)

         (SSA : forall (ftenv : funTC) (fenv: funEnv),
		  MatchEnvsT FunTyping fenv ftenv -> Type)

         (SSB : forall (ftenv : funTC) (fenv: funEnv)
                       (x:Id) (f: Fun) (ft:FTyp),
		  MatchEnvs2BT FunTyping x f ft fenv ftenv -> Type),

(** SSL cases **)

       (forall (ftenv : funTC) (tenv : valTC) (fenv: funEnv),
        SSL ftenv tenv fenv nil nil
           (Forall2_nilT (ExpTyping ftenv tenv fenv))) ->

       (forall (ftenv : funTC) (tenv : valTC) (fenv: funEnv)
               (es : list Exp) (ts : list VTyp)
               (e: Exp) (t: VTyp)
               (m1: ExpTyping ftenv tenv fenv e t)
               (m2 : Forall2T (ExpTyping ftenv tenv fenv) es ts),
        SSL ftenv tenv fenv es ts m2 ->
	PPE ftenv tenv fenv e t m1 ->
	SSL ftenv tenv fenv (e::es) (t::ts)
         (Forall2_consT (ExpTyping ftenv tenv fenv) e t es ts m1 m2)) ->

(** SSA cases **)

       (SSA nil nil (MatchEnvs_NilT FunTyping)) ->

       (forall (ftenv : funTC) (fenv : funEnv)
               (x:Id) (f: Fun) (t: FTyp)
               (m1: FunTyping f t)
               (m2 : MatchEnvsT FunTyping fenv ftenv),
        SSA ftenv fenv m2 ->
	PPF f t m1 ->
        SSA ((x,t)::ftenv) ((x,f)::fenv)
            (MatchEnvs_ConsT FunTyping fenv ftenv x f t m1 m2)) ->

(** SSB cases **)

       (forall (ftenv ftenv0 ftenv1: funTC)
               (fenv fenv0 fenv1: funEnv)
               (x:Id) (f: Fun) (t: FTyp)
               (k: FunTyping f t)
               (m0 : MatchEnvsT FunTyping fenv0 ftenv0)
               (m1 : MatchEnvsT FunTyping fenv1 ftenv1)
               (h1 : findE ftenv0 x = None)
               (h2 : fenv = fenv0 ++ ((x,f)::fenv1))
               (h3 : ftenv = ftenv0 ++ ((x,t)::ftenv1)),
        SSA ftenv0 fenv0 m0 ->
        SSA ftenv1 fenv1 m1 ->
        PPF f t k ->
        SSB ftenv fenv x f t
           (MatchEnvs2B_splitT FunTyping x f t
               fenv ftenv fenv0 ftenv0 fenv1 ftenv1 k m0 m1 h1 h2 h3)) ->

(** PPF cases *)

(* FunZ *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
          (e0 e1 : Exp) (x : Id) (t : VTyp)
          (m : MatchEnvsT FunTyping fenv ftenv)
          (k : ExpTyping ftenv tenv fenv e0 t),
        PPE ftenv tenv fenv e0 t k ->
        PPF (FC fenv tenv e0 e1 x 0) (FT tenv t)
            (FunZ_Typing ftenv tenv fenv e0 e1 x t m k)) ->

(* FunS *)
       (forall (ftenv : funTC) (tenv : valTC)
               (fenv : funEnv)
               (e0 e1 : Exp) (x : Id)
               (n : nat) (t : VTyp),
        let ftenv' := (x, FT tenv t) :: ftenv in
        let fenv' := (x, FC fenv tenv e0 e1 x n) :: fenv in
        forall (m : MatchEnvsT FunTyping fenv ftenv)
               (k1 : ExpTyping ftenv' tenv fenv' e1 t)
               (k2 : FunTyping (FC fenv tenv e0 e1 x n) (FT tenv t)),
        PPE ftenv' tenv fenv' e1 t k1 ->
        PPF (FC fenv tenv e0 e1 x n) (FT tenv t) k2 ->
        PPF (FC fenv tenv e0 e1 x (S n)) (FT tenv t)
                (FunS_Typing ftenv tenv fenv
                                      e0 e1 x n t m k1 k2)) ->

(** PPQ cases *)

(* QF *)
       (forall (ftenv : funTC) (fenv : funEnv)
               (f : Fun) (ft : FTyp)
               (k : FunTyping f ft),
        PPF f ft k ->
        PPQ ftenv fenv (QF f) ft (QF_Typing ftenv fenv f ft k)) ->

(* FVar  *)
       (forall (ftenv : funTC) (fenv : funEnv) (x : Id)
               (f : Fun) (ft : FTyp)
               (m : MatchEnvs2BT FunTyping x f ft fenv ftenv),
        SSB ftenv fenv x f ft m ->
        PPQ ftenv fenv (FVar x) ft (FVar_Typing ftenv fenv x f ft m)) ->

(** PPE cases *)

(* Modify *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (T1 T2 : Type) (VT1 : ValTyp T1) (VT2 : ValTyp T2)
               (XF: XFun T1 T2) (q : QValue)
               (k : QValueTyping tenv q (vtyp T1)),
        PPE ftenv tenv fenv (Modify T1 T2 VT1 VT2 XF q) (vtyp T2)
              (Modify_Typing ftenv tenv fenv T1 T2 VT1 VT2 XF q k)) ->

(* Return *)
       (forall (G : Tag)
               (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (q : QValue) (t : VTyp)
               (k : QValueTyping tenv q t),
        PPE ftenv tenv fenv (Return G q) t
            (Return_Typing G ftenv tenv fenv q t k)) ->

(* BindN *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (e1 e2 : Exp) (t1 t2 : VTyp)
               (k1 : ExpTyping ftenv tenv fenv e1 t1)
               (k2 : ExpTyping ftenv tenv fenv e2 t2),
        PPE ftenv tenv fenv e1 t1 k1 ->
        PPE ftenv tenv fenv e2 t2 k2 ->
        PPE ftenv tenv fenv (BindN e1 e2) t2
            (BindN_Typing ftenv tenv fenv e1 e2 t1 t2 k1 k2)) ->

(* BindS *)
       (forall (ftenv : funTC) (tenv : valTC)
               (fenv : funEnv) (x : Id) (e1 e2 : Exp) (t1 t2 : VTyp),
        let tenv' := (x, t1) :: tenv in
        forall (k1 : ExpTyping ftenv tenv fenv e1 t1)
               (k2 : ExpTyping ftenv tenv' fenv e2 t2),
        PPE ftenv tenv fenv e1 t1 k1 ->
        PPE ftenv tenv' fenv e2 t2 k2 ->
        PPE ftenv tenv fenv (BindS x e1 e2) t2
            (BindS_Typing ftenv tenv fenv x e1 e2 t1 t2 k1 k2)) ->

(* BindMS *)
       (forall (ftenv ftenvP ftenv' : funTC) (tenv tenvP tenv' : valTC)
               (fenv fenvP fenv' : funEnv) (envP : valEnv)
               (e : Exp) (t : VTyp)
               (k1 : EnvTyping envP tenvP)
               (m1 : MatchEnvsT FunTyping fenv ftenv)
               (m2 : MatchEnvsT FunTyping fenvP ftenvP)
               (h1: tenv' = tenvP ++ tenv)
               (h2: ftenv' = ftenvP ++ ftenv)
               (h3: fenv' = fenvP ++ fenv)
               (k2: ExpTyping ftenv' tenv' fenv' e t),
        PPE ftenv' tenv' fenv' e t k2 ->
        PPE ftenv tenv fenv (BindMS fenvP envP e) t
          (BindMS_Typing ftenv ftenvP ftenv' tenv tenvP tenv' fenv fenvP
             fenv' envP e t k1 m1 m2 h1 h2 h3 k2)) ->

(* Apply *)
       (forall (ftenv : funTC) (tenv fps : valTC) (fenv : funEnv)
               (q : QFun) (ps : Prms) (pt : PTyp) (t : VTyp)
               (h : pt = env2ptyp fps)
               (m : MatchEnvsT FunTyping fenv ftenv)
               (k1 : QFunTyping ftenv fenv q (FT fps t))
               (k2 : PrmsTyping ftenv tenv fenv ps pt),
        PPQ ftenv fenv q (FT fps t) k1 ->
        PPP ftenv tenv fenv ps pt k2 ->
        PPE ftenv tenv fenv (Apply q ps) t
            (Apply_Typing ftenv tenv fps fenv q ps pt t h m k1 k2)) ->

(* Val *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (v : Value) (t : VTyp)
               (k : ValueTyping v t),
          PPE ftenv tenv fenv (Val v) t
              (Val_Typing ftenv tenv fenv v t k)) ->

(* IfThenElse *)

       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
          (e1 e2 e3 : Exp) (t : VTyp)
          (k1 : ExpTyping ftenv tenv fenv e1 Bool)
          (k2 : ExpTyping ftenv tenv fenv e2 t)
          (k3 : ExpTyping ftenv tenv fenv e3 t),
        PPE ftenv tenv fenv e1 Bool k1 ->
        PPE ftenv tenv fenv e2 t k2 ->
        PPE ftenv tenv fenv e3 t k3 ->
        PPE ftenv tenv fenv (IfThenElse e1 e2 e3) t
           (IfThenElse_Typing ftenv tenv fenv e1 e2 e3 t k1 k2 k3)) ->

(** PPP cases *)

(* PS *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (es : list Exp) (ts : list VTyp)
               (m : Forall2T (ExpTyping ftenv tenv fenv) es ts),
        SSL ftenv tenv fenv es ts m ->
        PPP ftenv tenv fenv (PS es) (PT ts)
            (PS_Typing ftenv tenv fenv es ts m)) ->

(** PPQ conclusion *)

       forall (ftenv : funTC) (fenv : funEnv)
              (q : QFun) (ft : FTyp)
              (k: QFunTyping ftenv fenv q ft),
       PPQ ftenv fenv q ft k.

Proof.
  intros PPF PPQ PPE PPP SSL SSA SSB.
  intros.
  revert q ft k.
  revert ftenv fenv.

  fix HP_Q 5 with

  (HP_F (f : Fun) (ft : FTyp) (k: FunTyping f ft) {struct k}:
                                           PPF f ft k)
  (HP_E (ftenv : funTC) (tenv : valTC) (fenv : funEnv) (e : Exp)
        (v : VTyp) (k: ExpTyping ftenv tenv fenv e v) {struct k}:
                                           PPE ftenv tenv fenv e v k)
  (HP_P (ftenv : funTC) (tenv : valTC) (fenv: funEnv) (ps : Prms) (ts : PTyp)
       (k: PrmsTyping ftenv tenv fenv ps ts) {struct k}:
                                           PPP ftenv tenv fenv ps ts k).
(* PPQ *)
- intros.
  destruct k.
  + apply X6.
    apply HP_F.
  + apply X7.
    destruct m.
    * apply X3.
      {- revert m e.
         subst ls5 ls6.
         revert ls2 ls1.
         fix HP_QA 3.
         intros.
         destruct m.
         + apply X1.
         + apply X2.
           * apply HP_QA.
             {- inversion e; subst.
                destruct (IdT.IdEqDec x k).
                + inversion H0.
                + reflexivity.
             }
           * apply HP_F.
      }
      {- revert m0 e.
         subst ls5 ls6.
         revert ls4 ls3.
         fix HP_QA 3.
         intros.
         destruct m0.
         + apply X1.
         + apply X2.
           * apply HP_QA.
             {- exact e. }
           * apply HP_F.
      }
      {- apply HP_F. }
(* PPF *)
- intros.
  destruct k.
  + apply X4.
    apply HP_E.
  + apply X5.
    apply HP_E.
    apply HP_F.
(* PPE *)
- intros.
  destruct k.
  + apply X8.
  + apply X9.
  + apply X10.
    * apply HP_E.
    * apply HP_E.
  + apply X11.
    * apply HP_E.
    * apply HP_E.
  + apply X12.
    * apply HP_E.
  + apply X13.
    * apply HP_Q.
    * apply HP_P.
  + apply X14.
  + apply X15.
    * apply HP_E.
    * apply HP_E.
    * apply HP_E.
(* PPP *)
- intros.
  destruct k.
  apply X16.
  revert f.
  revert es ts.
  fix HP_QL 3.
  intros.
  destruct f.
  + apply X.
  + apply X0.
    * apply HP_QL.
    * apply HP_E.
Defined.

Definition QFunTyping_str_rect PPF PPQ PPE PPP :=
  QFunTyping_gen_str_rect PPF PPQ PPE PPP
       (Par_SSL PPE) (Par_SSA PPF) (Par_SSB PPF).

(***********************************************************************)

Lemma PrmsTyping_gen_str_rect : forall

(* properties *)

         (PPF : forall (f : Fun) (ft : FTyp),
                  FunTyping f ft -> Type)

         (PPQ : forall (ftenv : funTC) (fenv : funEnv)
                       (q : QFun) (ft : FTyp),
                  QFunTyping ftenv fenv q ft -> Type)

         (PPE : forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
                       (e : Exp) (v : VTyp),
                  ExpTyping ftenv tenv fenv e v -> Type)

         (PPP : forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
                       (ps : Prms) (pt : PTyp),
                  PrmsTyping ftenv tenv fenv ps pt -> Type)

         (SSL : forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
                       (es: list Exp) (ts: list VTyp),
		  Forall2T (ExpTyping ftenv tenv fenv) es ts -> Type)

         (SSA : forall (ftenv : funTC) (fenv: funEnv),
		  MatchEnvsT FunTyping fenv ftenv -> Type)

         (SSB : forall (ftenv : funTC) (fenv: funEnv)
                       (x:Id) (f: Fun) (ft:FTyp),
		  MatchEnvs2BT FunTyping x f ft fenv ftenv -> Type),

(** SSL cases **)

       (forall (ftenv : funTC) (tenv : valTC) (fenv: funEnv),
        SSL ftenv tenv fenv nil nil
           (Forall2_nilT (ExpTyping ftenv tenv fenv))) ->

       (forall (ftenv : funTC) (tenv : valTC) (fenv: funEnv)
               (es : list Exp) (ts : list VTyp)
               (e: Exp) (t: VTyp)
               (m1: ExpTyping ftenv tenv fenv e t)
               (m2 : Forall2T (ExpTyping ftenv tenv fenv) es ts),
        SSL ftenv tenv fenv es ts m2 ->
	PPE ftenv tenv fenv e t m1 ->
	SSL ftenv tenv fenv (e::es) (t::ts)
         (Forall2_consT (ExpTyping ftenv tenv fenv) e t es ts m1 m2)) ->

(** SSA cases **)

       (SSA nil nil (MatchEnvs_NilT FunTyping)) ->

       (forall (ftenv : funTC) (fenv : funEnv)
               (x:Id) (f: Fun) (t: FTyp)
               (m1: FunTyping f t)
               (m2 : MatchEnvsT FunTyping fenv ftenv),
        SSA ftenv fenv m2 ->
	PPF f t m1 ->
        SSA ((x,t)::ftenv) ((x,f)::fenv)
            (MatchEnvs_ConsT FunTyping fenv ftenv x f t m1 m2)) ->

(** SSB cases **)

       (forall (ftenv ftenv0 ftenv1: funTC)
               (fenv fenv0 fenv1: funEnv)
               (x:Id) (f: Fun) (t: FTyp)
               (k: FunTyping f t)
               (m0 : MatchEnvsT FunTyping fenv0 ftenv0)
               (m1 : MatchEnvsT FunTyping fenv1 ftenv1)
               (h1 : findE ftenv0 x = None)
               (h2 : fenv = fenv0 ++ ((x,f)::fenv1))
               (h3 : ftenv = ftenv0 ++ ((x,t)::ftenv1)),
        SSA ftenv0 fenv0 m0 ->
        SSA ftenv1 fenv1 m1 ->
        PPF f t k ->
        SSB ftenv fenv x f t
           (MatchEnvs2B_splitT FunTyping x f t
               fenv ftenv fenv0 ftenv0 fenv1 ftenv1 k m0 m1 h1 h2 h3)) ->

(** PPF cases *)

(* FunZ *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
          (e0 e1 : Exp) (x : Id) (t : VTyp)
          (m : MatchEnvsT FunTyping fenv ftenv)
          (k : ExpTyping ftenv tenv fenv e0 t),
        PPE ftenv tenv fenv e0 t k ->
        PPF (FC fenv tenv e0 e1 x 0) (FT tenv t)
            (FunZ_Typing ftenv tenv fenv e0 e1 x t m k)) ->

(* FunS *)
       (forall (ftenv : funTC) (tenv : valTC)
               (fenv : funEnv)
               (e0 e1 : Exp) (x : Id)
               (n : nat) (t : VTyp),
        let ftenv' := (x, FT tenv t) :: ftenv in
        let fenv' := (x, FC fenv tenv e0 e1 x n) :: fenv in
        forall (m : MatchEnvsT FunTyping fenv ftenv)
               (k1 : ExpTyping ftenv' tenv fenv' e1 t)
               (k2 : FunTyping (FC fenv tenv e0 e1 x n) (FT tenv t)),
        PPE ftenv' tenv fenv' e1 t k1 ->
        PPF (FC fenv tenv e0 e1 x n) (FT tenv t) k2 ->
        PPF (FC fenv tenv e0 e1 x (S n)) (FT tenv t)
                (FunS_Typing ftenv tenv fenv
                                      e0 e1 x n t m k1 k2)) ->

(** PPQ cases *)

(* QF *)
       (forall (ftenv : funTC) (fenv : funEnv)
               (f : Fun) (ft : FTyp)
               (k : FunTyping f ft),
        PPF f ft k ->
        PPQ ftenv fenv (QF f) ft (QF_Typing ftenv fenv f ft k)) ->

(* FVar  *)
       (forall (ftenv : funTC) (fenv : funEnv) (x : Id)
               (f : Fun) (ft : FTyp)
               (m : MatchEnvs2BT FunTyping x f ft fenv ftenv),
        SSB ftenv fenv x f ft m ->
        PPQ ftenv fenv (FVar x) ft (FVar_Typing ftenv fenv x f ft m)) ->

(** PPE cases *)

(* Modify *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (T1 T2 : Type) (VT1 : ValTyp T1) (VT2 : ValTyp T2)
               (XF: XFun T1 T2) (q : QValue)
               (k : QValueTyping tenv q (vtyp T1)),
        PPE ftenv tenv fenv (Modify T1 T2 VT1 VT2 XF q) (vtyp T2)
              (Modify_Typing ftenv tenv fenv T1 T2 VT1 VT2 XF q k)) ->

(* Return *)
       (forall (G : Tag)
               (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (q : QValue) (t : VTyp)
               (k : QValueTyping tenv q t),
        PPE ftenv tenv fenv (Return G q) t
            (Return_Typing G ftenv tenv fenv q t k)) ->

(* BindN *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (e1 e2 : Exp) (t1 t2 : VTyp)
               (k1 : ExpTyping ftenv tenv fenv e1 t1)
               (k2 : ExpTyping ftenv tenv fenv e2 t2),
        PPE ftenv tenv fenv e1 t1 k1 ->
        PPE ftenv tenv fenv e2 t2 k2 ->
        PPE ftenv tenv fenv (BindN e1 e2) t2
            (BindN_Typing ftenv tenv fenv e1 e2 t1 t2 k1 k2)) ->

(* BindS *)
       (forall (ftenv : funTC) (tenv : valTC)
               (fenv : funEnv) (x : Id) (e1 e2 : Exp) (t1 t2 : VTyp),
        let tenv' := (x, t1) :: tenv in
        forall (k1 : ExpTyping ftenv tenv fenv e1 t1)
               (k2 : ExpTyping ftenv tenv' fenv e2 t2),
        PPE ftenv tenv fenv e1 t1 k1 ->
        PPE ftenv tenv' fenv e2 t2 k2 ->
        PPE ftenv tenv fenv (BindS x e1 e2) t2
            (BindS_Typing ftenv tenv fenv x e1 e2 t1 t2 k1 k2)) ->

(* BindMS *)
       (forall (ftenv ftenvP ftenv' : funTC) (tenv tenvP tenv' : valTC)
               (fenv fenvP fenv' : funEnv) (envP : valEnv)
               (e : Exp) (t : VTyp)
               (k1 : EnvTyping envP tenvP)
               (m1 : MatchEnvsT FunTyping fenv ftenv)
               (m2 : MatchEnvsT FunTyping fenvP ftenvP)
               (h1: tenv' = tenvP ++ tenv)
               (h2: ftenv' = ftenvP ++ ftenv)
               (h3: fenv' = fenvP ++ fenv)
               (k2: ExpTyping ftenv' tenv' fenv' e t),
        PPE ftenv' tenv' fenv' e t k2 ->
        PPE ftenv tenv fenv (BindMS fenvP envP e) t
          (BindMS_Typing ftenv ftenvP ftenv' tenv tenvP tenv' fenv fenvP
             fenv' envP e t k1 m1 m2 h1 h2 h3 k2)) ->

(* Apply *)
       (forall (ftenv : funTC) (tenv fps : valTC) (fenv : funEnv)
               (q : QFun) (ps : Prms) (pt : PTyp) (t : VTyp)
               (h : pt = env2ptyp fps)
               (m : MatchEnvsT FunTyping fenv ftenv)
               (k1 : QFunTyping ftenv fenv q (FT fps t))
               (k2 : PrmsTyping ftenv tenv fenv ps pt),
        PPQ ftenv fenv q (FT fps t) k1 ->
        PPP ftenv tenv fenv ps pt k2 ->
        PPE ftenv tenv fenv (Apply q ps) t
            (Apply_Typing ftenv tenv fps fenv q ps pt t h m k1 k2)) ->

(* Val *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (v : Value) (t : VTyp)
               (k : ValueTyping v t),
          PPE ftenv tenv fenv (Val v) t
              (Val_Typing ftenv tenv fenv v t k)) ->

(* IfThenElse *)

       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
          (e1 e2 e3 : Exp) (t : VTyp)
          (k1 : ExpTyping ftenv tenv fenv e1 Bool)
          (k2 : ExpTyping ftenv tenv fenv e2 t)
          (k3 : ExpTyping ftenv tenv fenv e3 t),
        PPE ftenv tenv fenv e1 Bool k1 ->
        PPE ftenv tenv fenv e2 t k2 ->
        PPE ftenv tenv fenv e3 t k3 ->
        PPE ftenv tenv fenv (IfThenElse e1 e2 e3) t
           (IfThenElse_Typing ftenv tenv fenv e1 e2 e3 t k1 k2 k3)) ->

(** PPP cases *)

(* PS *)
       (forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
               (es : list Exp) (ts : list VTyp)
               (m : Forall2T (ExpTyping ftenv tenv fenv) es ts),
        SSL ftenv tenv fenv es ts m ->
        PPP ftenv tenv fenv (PS es) (PT ts)
            (PS_Typing ftenv tenv fenv es ts m)) ->

(** PPP conclusion *)

       forall (ftenv : funTC) (tenv : valTC) (fenv : funEnv)
              (ps : Prms) (pt : PTyp)
              (k: PrmsTyping ftenv tenv fenv ps pt),
       PPP ftenv tenv fenv ps pt k.

Proof.
  intros PPF PPQ PPE PPP SSL SSA SSB.
  intros.
  revert ps pt k.
  revert ftenv tenv fenv.

  fix HP_P 6 with

  (HP_F (f : Fun) (ft : FTyp) (k: FunTyping f ft) {struct k}:
                                           PPF f ft k)
  (HP_E (ftenv : funTC) (tenv : valTC) (fenv : funEnv) (e : Exp)
        (v : VTyp) (k: ExpTyping ftenv tenv fenv e v) {struct k}:
                                           PPE ftenv tenv fenv e v k)
  (HP_Q (ftenv : funTC) (fenv: funEnv) (h : QFun) (ft : FTyp)                           (k: QFunTyping ftenv fenv h ft) {struct k}:
                                           PPQ ftenv fenv h ft k).

(* PPP *)
- intros.
  destruct k.
  apply X16.
  revert f.
  revert es ts.
  fix HP_QL 3.
  intros.
  destruct f.
  + apply X.
  + apply X0.
    * apply HP_QL.
    * apply HP_E.
(* PPF *)
- intros.
  destruct k.
  + apply X4.
    apply HP_E.
  + apply X5.
    apply HP_E.
    apply HP_F.
(* PPE *)
- intros.
  destruct k.
  + apply X8.
  + apply X9.
  + apply X10.
    * apply HP_E.
    * apply HP_E.
  + apply X11.
    * apply HP_E.
    * apply HP_E.
  + apply X12.
    * apply HP_E.
  + apply X13.
    * apply HP_Q.
    * apply HP_P.
  + apply X14.
  + apply X15.
    * apply HP_E.
    * apply HP_E.
    * apply HP_E.
(* PPQ *)
- intros.
  destruct k.
  + apply X6.
    apply HP_F.
  + apply X7.
    destruct m.
    * apply X3.
      {- revert m e.
         subst ls5 ls6.
         revert ls2 ls1.
         fix HP_QA 3.
         intros.
         destruct m.
         + apply X1.
         + apply X2.
           * apply HP_QA.
             {- inversion e; subst.
                destruct (IdT.IdEqDec x k).
                + inversion H0.
                + reflexivity.
             }
           * apply HP_F.
      }
      {- revert m0 e.
         subst ls5 ls6.
         revert ls4 ls3.
         fix HP_QA 3.
         intros.
         destruct m0.
         + apply X1.
         + apply X2.
           * apply HP_QA.
             {- exact e. }
           * apply HP_F.
      }
      {- apply HP_F. }
Defined.

Definition PrmsTyping_str_rect PPF PPQ PPE PPP :=
  PrmsTyping_gen_str_rect PPF PPQ PPE PPP
       (Par_SSL PPE) (Par_SSA PPF) (Par_SSB PPF).

End TRInduct.


Require Export Ascii String List Arith Omega Vector List.
Require Export Algorithm.Full1D.
Require Export Printers.Nat.
Import NatPrinter.

Local Open Scope string_scope.

Module Export PrinterHelpers.
  Lemma ne_S_0 {x} : S x <> 0. Proof. omega. Qed.
  Lemma ne_SS_1 {x} : S (S x) <> 1. Proof. omega. Qed.

  Definition focus {T} (_ : T) := True.
  Definition focusI {T} {x : T} : focus x := I.
  Global Opaque focus.

  Definition make_star_points st
    := ("*",
        ((Vector.to_list (projT2 (ClosestPoints1D.state.left_points st)))
           ++ (Vector.to_list (projT2 (ClosestPoints1D.state.right_points st))))%list).
  Definition make_oh_points {A} (pts : A * A)
    := ("o", (fst pts)::(snd pts)::List.nil).

  Class auto (T : Type) := auto_intro : T.

  Global Hint Extern 1 (auto _) => hnf; apply ne_S_0 : typeclass_instances.
  Global Hint Extern 1 (auto _) => hnf; apply ne_SS_1 : typeclass_instances.

  Definition make_tree_from_list points
             `{H' : auto (Datatypes.length points <> 0)}
             `{H'' : auto (Datatypes.length points <> 1)}
    := match @ClosestPoints1D.make_algorithm_tree_from_point_set
               _ (Vector.of_list points) with
         | inl x => x
         | inr (left H) => match H' H with end
         | inr (right H) => match H'' H with end
       end.

  Definition make_display_from_tree s points :=
    ("                            "::(snd
                                        (@ClosestPoints1D.walk_algorithm_tree_in_order
                                           _ _

                                           (** at the leaves, what do we do? *)
                                           (** we display the other points as [.], the current points as [*], and the closest points as [o] *)
                                           (fun pts lines =>
                                              let disp_points' := make_oh_points pts::(".", points)::List.nil in
                                              (lines,
                                               string_list_of_nats_with_lines_and_points
                                                 points
                                                 lines
                                                 disp_points'))

                                           (** before each split, what do we display? *)
                                           (** We display the new median line as [|], the old one as [:] *)
                                           (fun st lines => let lines' := ((ClosestPoints1D.state.median st)::lines)%list in
                                                            let star := make_star_points st in
                                                            (lines',
                                                             (string_list_of_nats_with_lines_and_points
                                                                points
                                                                lines'
                                                                (star::(".", points)::List.nil))::List.nil))

                                           (** after we come back from the left side, what do we display? *)
                                           (** We display the points we care about, keeping the [o] points, but removing the [.] points *)
                                           (fun st lines =>
                                              let disp_points := ((make_oh_points (ClosestPoints1D.state.closest_left_points st))
                                                                    ::make_star_points st
                                                                    ::(".", points)
                                                                    ::List.nil) in
                                              (lines,
                                               string_list_of_nats_with_lines_and_points
                                                 points
                                                 lines
                                                 disp_points::List.nil))

                                           (** after we come back from the right side, what do we display? *)
                                           (** First we display the points we care about, keeping the [o] points.
                          Then we display the center strip.
                          Then we display the center strip with the closest points on it.
                          Then we display the closest points we know about so far. *)
                                           (fun st lines =>
                                              (lines,
                                               (((** First, we display the points we care about, with the [o] points on the right *)
                                                   string_list_of_nats_with_lines_and_points
                                                     points
                                                     lines
                                                     ((make_oh_points (ClosestPoints1D.state.closest_right_points st))
                                                        ::make_star_points st
                                                        ::(".", points)
                                                        ::List.nil))
                                                  ::((** Then, we display the center strip *)
                                                    string_list_of_nats_with_lines_and_points
                                                      points
                                                      lines
                                                      (("*", ClosestPoints1D.state.center_points st)
                                                         ::(".", points)
                                                         ::List.nil))
                                                  ::((** Then, we display the center strip with its closest points *)
                                                    string_list_of_nats_with_lines_and_points
                                                      points
                                                      lines
                                                      ((make_oh_points (ClosestPoints1D.state.closest_center_points st))
                                                         ::("*", ClosestPoints1D.state.center_points st)
                                                         ::(".", points)
                                                         ::List.nil))
                                                  ::((** Then, we display the closest points we know about so far *)
                                                    string_list_of_nats_with_lines_and_points
                                                      points
                                                      lines
                                                      ((make_oh_points (ClosestPoints1D.state.closest_points st))
                                                         ::make_star_points st
                                                         ::(".", points)
                                                         ::List.nil))
                                                  ::List.nil)))
                                           s
                                           List.nil))).

  Ltac step_then p n_hyp tac :=
    let l := match type of p with
               | focus ?l => constr:(l)
             end in
    let n := match type of n_hyp with
               | focus ?n => constr:(n)
             end in
    let s := constr:(@nth_default _ "DONE" l n) in
    let s' := (eval lazy in s) in
    idtac s';
      tac n_hyp n.

  Ltac next p n_hyp :=
    step_then p n_hyp ltac:(fun n_hyp n => replace_hyp n_hyp (focusI : focus (S n))).
  Ltac prev p n_hyp :=
    step_then p n_hyp ltac:(fun n_hyp n => replace_hyp n_hyp (focusI : focus (pred n))).

  Definition make_display_from_list points `{H' : _, H'' : _} :=
    make_display_from_tree (@make_tree_from_list points H' H'') points.
End PrinterHelpers.


From Coq Require Import String BinNat Ascii BinNatDef Vector List.
From HTTP2 Require Import
     Equiv
     Types.
From HTTP2.Util Require Import
     BitVector
     Parser
     VectorUtil
     StringUtil.
From HTTP2.HPACK Require Import HPACKTypes HPACKTables.
From ExtLib Require Import Monads.
Import MonadNotation.
Import ListNotations.
Open Scope string_scope.
Open Scope N_scope.
Open Scope monad_scope.
Open Scope list_scope.

(* Decodes a string to an integer where at least the first octet (ascii) is
   assumed to be an encoded integer. The prefix is a value of n bits.
    https://tools.ietf.org/html/rfc7541#section-5.1

Pseudocode to decode an integer I with an N bit prefix is as follows:

decode I from the next N bits
if I < 2^N - 1, return I
else
    M = 0
    repeat
        B = next octet
        I = I + (B & 127) * 2^M
        M = M + 7
    while B & 128 == 128
    return I
 *)
Fixpoint decode_integer_h {m:Tycon} `{Monad m} `{MonadExc HPACKError m}
           `{MParser byte m} (fuel:nat) (M:N) : m N :=
  match fuel with
  | O =>  raise IntegerOverflow
  | S fuel' => a <- get_byte ;;
            let B := (N_of_ascii a) in
            let I := (BinNatDef.N.land B 127) * 2^M in
            if N.land B 128 =? 128
            then e <- decode_integer_h (fuel') (M + 7);;
                 ret (I + e)
            else ret I
  end.

(* To justify using fuel (and the value) in decode_integer_h:

   "Integer encodings that exceed implementation limits -- in
    value or octet length -- MUST be treated as decoding errors.
    Different limits can be set for each of the different uses of
    integers, based on implementation constraints."

   For fuel, I used 100, because integers are only used as indices,
   which means the dynamic table would have to have size 2^100 for this
   to be a problem.

   Alternatively, the fuel could be a parameter passed in from when the
   header block fragments are combined to form a header block, or used in
   an MParser with an internal fuel.
*)
Definition decode_integer {m:Tycon} `{Monad m} `{MonadExc HPACKError m}
           `{MParser byte m} (prefix:N) (n:N) : m N :=
  if prefix <? 2^n - 1 then ret prefix
  else a <- decode_integer_h 0 100 ;;
       ret (prefix + a).

(*  https://tools.ietf.org/html/rfc7541#section-5.2 *)
(* Decodes the huffman encoded string s *)
Definition list_eqb (l1 l2: list bool) :=
  if list_eq_dec Bool.bool_dec l1 l2 then true else false.

Program Fixpoint lookup (l:list bool) { measure (length l) } :=
  match l with
  | [] => None
  | _ =>
    match find (fun '(a, bs) => list_eqb l bs) huffman_table with
    | None =>
      let a := last l false in
      let l' := removelast l in
      option_map (fun '(v, l) => (v, l ++ [a])) (lookup l')
    | Some v =>
      Some (fst v, [])
    end
  end.
Obligation 1. apply removelast_decreasing; auto.
Defined.

(* Double check this code, maybe rewrite for clarity *)
Fixpoint decode_hstring_h {m:Tycon} `{Monad m} `{MonadExc HPACKError m}
         `{MParser byte m} (buffer:list bool) (s:string) : m string :=
  match s with
  | EmptyString =>
    if PeanoNat.Nat.ltb (length buffer) 8 && fold_left (fun acc b => b && acc) buffer true
    then ret "" else raise EmptyEncodedString
  | String a s' =>
    match a with
    | Ascii b7 b6 b5 b4 b3 b2 b1 b0 =>
      (* To catch the case where an entire huffman encoded string is contained
         in b0-b7, run lookup twice.
         Note since a requirement of huffman is that no encoded string is a prefix
         of another encoded string, it's safe to look further, ie look at all 8 bits
         first. *)
      let buffer' := (buffer ++ [b0; b1; b2; b3; b4; b5; b6; b7]) in
      match lookup buffer' with
      | None => decode_hstring_h buffer' s'
      | Some (a, l) =>
        if a =? 256 then raise EosInTheMiddle
        else
          match lookup l with
          | None =>
            v <- decode_hstring_h l s';;
            ret (String (ascii_of_N a) v)
          | Some (b, l') =>
            v <- decode_hstring_h l' s';;
            ret (String (ascii_of_N a) (String (ascii_of_N b) v))
          end
      end
    end
  end.

Definition decode_hstring {m:Tycon} `{Monad m} `{MonadExc HPACKError m}
           `{MParser byte m} (s:string) : m string :=
  decode_hstring_h List.nil s.

(* Decodes an encoded string to a raw string. *)
Definition decode_string {m:Tycon} `{Monad m} `{MonadExc HPACKError m}
           `{MParser byte m} : m string :=
  a <- get_byte ;;
  let n := N_of_ascii a in
  let prefix := N.land n 127 in
  len <- decode_integer prefix 7 ;;
  s <- get_bytes_N len ;;
  let H := N.land n 128 in
  if BinNat.N.eqb H 128 then decode_hstring s
  else ret s.

(* https://tools.ietf.org/html/rfc7541#section-6 *)
(* Decodes a header field representation *)
Definition decode_HFR {m:Tycon} `{Monad m} `{MonadExc HPACKError m}
           `{MParser byte m} : m HeaderFieldRepresentation :=
  a <- get_byte ;;
  let octet := N_of_ascii a in
  let bit0 := N.land octet 128 in
  (* https://tools.ietf.org/html/rfc7541#section-6.1 *)
  if bit0 =? 128 then n <- decode_integer (N.land octet 127) 7;;
                      ret (IndexedHF n)
  else
    let bit1 := N.land octet 64 in
    (* https://tools.ietf.org/html/rfc7541#section-6.2.1 *)
    if bit1 =? 64
    then v <- decode_integer (N.land octet 63) 6;;
         if v =? 0 then v1 <- decode_string;;
                        v2 <- decode_string;;
                        ret (LHFIncrementNewName v1 v2)
           else v1 <- decode_string;;
                ret (LHFIncrementIndexedName v v1)
    else
      (* https://tools.ietf.org/html/rfc7541#section-6.3 *)
      let bit2 := N.land octet 32 in
      if bit2 =? 32 then n <- decode_integer (N.land octet 31) 5;;
                         ret (DTableSizeUpdate n)
      else
        (* https://tools.ietf.org/html/rfc7541#section-6.2.3 *)
        let bit3 := N.land octet 16 in
        if bit3 =? 16 then v <- decode_integer (N.land octet 15) 4;;
                           if v =? 0 then v1 <- decode_string;;
                                          v2 <- decode_string;;
                                          ret (LHFNeverIndexNewName v1 v2)
                           else v1 <- decode_string;;
                                ret (LHFNeverIndexIndexedName v v1)
        else
          (* https://tools.ietf.org/html/rfc7541#section-6.2.2 *)
          v <- decode_integer (N.land octet 15) 4;;
          if v =? 0 then v1 <- decode_string;;
                         v2 <- decode_string;;
                         ret (LHFWithoutIndexNewName v1 v2)
          else v1 <- decode_string;;
               ret (LHFWithoutIndexIndexedName v v1).

Fixpoint decode_HB_h {m:Tycon} `{Monad m} `{MonadExc HPACKError m}
         `{MParser byte m} (n:nat) : m HeaderBlock :=
  match n with
  | O => raise HeaderBlockOverflow
  | S n' =>
    h <- decode_HFR;;
    hs <- catch (decode_HB_h n') (fun e =>
                            match e with
                            | HeaderBlockTruncated =>
                              ret []
                            | _ => raise e
                            end);;
    ret (h :: hs)
  end.

Definition decode_HB {m:Tycon} `{Monad m} `{MonadExc HPACKError m}
           `{MParser byte m} : m HeaderBlock :=
  decode_HB_h 1000.


Require Import Ensembles.
Require Import Variables.
Require Import Lattice.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.RelationClasses.

Require Import Lifetime.
(* Scheme equality eq_dec, Scheme Boolean Equality beq, search for eq_A*)

Module Value.

    Definition location : Type := sum (Var.t * Lifetime.t) nat.

    Inductive kind : Set :=
    | Owned : kind (* black square *)
    | Borrowed : kind (* white circle *)
    | Trc : bool -> kind. (* losange *)

    Inductive value : Type :=
        | Unit : value
        | Int : nat -> value
        | Location : location -> kind -> value.

    Definition partialValue : Type := option value.

End Value.