(** * Autosubst Header for Unnamed Syntax

Version: December 11, 2019.
 *)

Require Export axioms.

Definition ap {X Y} (f : X -> Y) {x y : X} (p : x = y) : f x = f y :=
  match p with eq_refl => eq_refl end.

Definition apc {X Y} {f g : X -> Y} {x y : X} (p : f = g) (q : x = y) : f x = g y :=
  match q with eq_refl => match p with eq_refl => eq_refl end end.

(** ** Primitives of the Sigma Calculus. *)

(* Definition None := 0. *)
(* Definition Some := S. *)

(* Notation fin := nat. *)
Definition shift  := S.

Definition var_zero := 0.

Definition id {X} (x: X) := x.

Definition scons {X: Type} (x : X) (xi : nat -> X) :=
  fun n => match n with
          |0 => x
          |S n => xi n
          end.

Notation "s .: sigma" := (scons s sigma) (at level 70).

Definition funcomp {X Y Z} (g : Y -> Z) (f : X -> Y)  :=
  fun x => g (f x).

(** ** Type Class Instances for Notation
Required to make notation work. *)

(** *** Type classes for renamings. *)

Class Ren1 (X1  : Type) (Y Z : Type) :=
  ren1 : X1 -> Y -> Z.

Class Ren2 (X1 X2 : Type) (Y Z : Type) :=
  ren2 : X1 -> X2 -> Y -> Z.

Class Ren3 (X1 X2 X3 : Type) (Y Z : Type) :=
  ren3 : X1 -> X2 -> X3 -> Y -> Z.

Class Ren4 (X1 X2 X3 X4 : Type) (Y Z : Type) :=
  ren4 : X1 -> X2 -> X3 -> X4 -> Y -> Z.

Class Ren5 (X1 X2 X3 X4 X5 : Type) (Y Z : Type) :=
  ren5 : X1 -> X2 -> X3 -> X4 -> X5 -> Y -> Z.

Notation "s ⟨ xi1 ⟩" := (ren1 xi1 s) (at level 7, left associativity, format "s  ⟨ xi1 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ⟩" := (ren3 xi1 xi2 xi3 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩" := (ren4  xi1 xi2 xi3 xi4 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩" := (ren5  xi1 xi2 xi3 xi4 xi5 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩") : subst_scope.

Notation "⟨ xi ⟩" := (ren1 xi) (at level 1, left associativity, format "⟨ xi ⟩") : fscope.

Notation "⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2) (at level 1, left associativity, format "⟨ xi1 ; xi2 ⟩") : fscope.

(** *** Type Classes for Substiution *)

Class Subst1 (X1 : Type) (Y Z: Type) :=
  subst1 : X1 -> Y -> Z.

Class Subst2 (X1 X2 : Type) (Y Z: Type) :=
  subst2 : X1 -> X2 -> Y  -> Z.

Class Subst3 (X1 X2 X3 : Type) (Y Z: Type) :=
  subst3 : X1 -> X2 -> X3 ->  Y  -> Z.

Class Subst4 (X1 X2 X3 X4: Type) (Y Z: Type) :=
  subst4 : X1 -> X2 -> X3 -> X4 -> Y  -> Z.

Class Subst5 (X1 X2 X3 X4 X5 : Type) (Y Z: Type) :=
  subst5 : X1 -> X2 -> X3 -> X4 -> X5  -> Y  -> Z.

Notation "s [ sigma ]" := (subst1 sigma s) (at level 7, left associativity, format "s '/' [ sigma ]") : subst_scope.

Notation "s [ sigma ; tau ]" := (subst2 sigma tau s) (at level 7, left associativity, format "s '/' [ sigma ; '/'  tau ]") : subst_scope.

(** *** Type Class for Variables *)

Class Var X Y :=
  ids : X -> Y.

(** ** Proofs for the substitution primitives. *)

Arguments funcomp {X Y Z} (g)%fscope (f)%fscope.

Notation "f >> g" := (funcomp g f) (*fun x => g (f x)*) (at level 50) : subst_scope.
Open Scope subst_scope.

(** A generic lifting of a renaming. *)
Definition up_ren (xi : nat -> nat) :=
  0 .: (xi >> S).

(** A generic proof that lifting of renamings composes. *)
Lemma up_ren_ren (xi: nat -> nat) (zeta : nat -> nat) (rho: nat -> nat) (E: forall x, (xi >> zeta) x = rho x) :
  forall x, (up_ren xi >> up_ren zeta) x = up_ren rho x.
Proof.
  intros [|x].
  - reflexivity.
  - unfold up_ren. simpl. unfold funcomp. rewrite <- E. reflexivity.
Qed.

(** Eta laws. *)
Lemma scons_eta_id {n : nat} : var_zero .: shift = id :> (nat -> nat).
Proof. fext. intros [|x]; reflexivity. Qed.

Lemma scons_eta {T} (f : nat -> T) :
  f var_zero .: shift >> f = f.
Proof. fext. intros [|x]; reflexivity. Qed.

Lemma scons_comp (T: Type) U (s: T) (sigma: nat -> T) (tau: T -> U ) :
  (s .: sigma) >> tau = scons (tau s) (sigma >> tau) .
Proof.
  fext. intros [|x]; reflexivity.
Qed.

(** ** Notations for unscoped syntax *)

(** Generic fsimpl tactic: simplifies the above primitives in a goal. *)
Ltac fsimpl :=
  unfold up_ren; repeat match goal with
         | [|- context[id >> ?f]] => change (id >> f) with f (* AsimplCompIdL *)
         | [|- context[?f >> id]] => change (f >> id) with f (* AsimplCompIdR *)
         | [|- context [id ?s]] => change (id s) with s
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((?f >> ?g) >> ?h) with (f >> (g >> h)) (* AsimplComp *)
         | [|- context[(?s.:?sigma) var_zero]] => change ((s.:sigma)var_zero) with s
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((f >> g) >> h) with (f >> (g >> h))
        | [|- context[?f >> (?x .: ?g)]] =>
           change (f >> (x .: g)) with g
         | [|- context[var_zero]] =>  change var_zero with 0
         | [|- context[?x2 .: shift >> ?f]] =>
           change x2 with (f 0); rewrite (@scons_eta _ _ f)
         | [|- context[(?v .: ?g) 0]] =>
           change ((v .: g) 0) with v
         | [|- context[(?v .: ?g) (S ?n)]] =>
           change ((v .: g) (S n)) with (g n)
         | [|- context[?f 0 .: ?g]] =>
           change g with (shift >> f); rewrite scons_eta
         | _ => first [progress (rewrite ?scons_comp) | progress (rewrite ?scons_eta_id)]
 end.

(** Generic fsimpl tactic: simplifies the above primitives in the context *)
Ltac fsimplc :=
  unfold up_ren; repeat match goal with
         | [H : context[id >> ?f] |- _] => change (id >> f) with f in H(* AsimplCompIdL *)
         | [H: context[?f >> id] |- _] => change (f >> id) with f in H(* AsimplCompIdR *)
         | [H: context [id ?s] |- _]  => change (id s) with s in H
         | [H:  context[(?f >> ?g) >> ?h]  |- _] =>
           change ((?f >> ?g) >> ?h) with (f >> (g >> h)) in H(* AsimplComp *)
         | [H : context[(?s.:?sigma) var_zero]  |- _] => change ((s.:sigma)var_zero) with s in H
         | [H: context[(?f >> ?g) >> ?h]  |- _] =>
           change ((f >> g) >> h) with (f >> (g >> h)) in H
        | [H: context[?f >> (?x .: ?g)]  |- _] =>
           change (f >> (x .: g)) with g in H
         | [H: context[var_zero]  |- _] =>  change var_zero with 0 in H
         | [H: context[?x2 .: shift >> ?f]  |- _] =>
           change x2 with (f 0) in H; rewrite (@scons_eta _ _ f) in H
         | [H: context[(?v .: ?g) 0]  |- _] =>
           change ((v .: g) 0) with v in H
         | [H: context[(?v .: ?g) (S ?n)]  |- _] =>
           change ((v .: g) (S n)) with (g n) in H
         | [H: context[?f 0 .: ?g]  |- _] =>
           change g with (shift >> f); rewrite scons_eta in H
         | _ => first [progress (rewrite ?scons_comp in *)  | progress (rewrite ?scons_eta_id in *) ]
 end.

(** Simplification in both the goal and the context *)
Tactic Notation "fsimpl" "in" "*" :=
  fsimpl; fsimplc.

(* Notation "s , sigma" := (scons s sigma) (at level 60, format "s ,  sigma", right associativity) : subst_scope. *)

Notation "s '..'" := (scons s ids) (at level 1, format "s ..") : subst_scope.
Instance idsRen : Var nat nat := id.

Notation "↑" := (shift).

(** ** Tactics for unscoped syntax *)

(** Unfold of the instances in goal and context. *)
Ltac auto_unfold := unfold subst1, ren1, subst2, ren2, ids; unfold Subst1, Ren1, Subst2, Ren2, Var.

Ltac unfold_funcomp := match goal with
                       | |-  context[(?f >> ?g) ?s] => change ((f >> g) s) with (g (f s))
                       end.

(** Automatically does a case analysis on a natural number, useful for proofs with context renamings/context morphisms. *)
Tactic Notation "auto_case" tactic(t) :=  (match goal with
                                           | [|- forall (i : nat), _] => intros []; t
                                           end).


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
(** Refinement rules for disjoint rules *)
Require Import Coq.ZArith.ZArith Coq.Lists.List.
Require Import Fiat.Parsers.Refinement.PreTactics.
Require Import Fiat.Computation.Refinements.General.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.StringLike.FirstChar.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Parsers.ContextFreeGrammar.ValidReflective.
Require Import Fiat.Parsers.Refinement.DisjointLemmas.
Require Import Fiat.Parsers.Refinement.DisjointRulesCommon.
Require Import Fiat.Parsers.Refinement.PossibleTerminalsSets.
Require Import Fiat.Parsers.ParserInterface.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Common.List.DisjointFacts.
Export DisjointLemmas.Exports.
Import ListNotations.

Set Implicit Arguments.

Lemma find_first_char_such_that'_short {Char HSLM HSL}
      str P len
  : @find_first_char_such_that' Char HSLM HSL P len str <= len.
Proof.
  revert str; induction len; simpl; intros; [ reflexivity | ].
  destruct (get (length str - S len) str) eqn:H.
  { edestruct P; try omega.
    apply Le.le_n_S, IHlen. }
  { apply Le.le_n_S, IHlen. }
Qed.

Lemma find_first_char_such_that_short {Char HSLM HSL}
      str P
  : @find_first_char_such_that Char HSLM HSL str P <= length str.
Proof.
  apply find_first_char_such_that'_short.
Qed.

Lemma is_first_char_such_that__find_first_char_such_that {Char} {HSLM HSL} {HSLP : @StringLikeProperties Char HSLM HSL} str P
      might_be_empty
      (H : exists n, is_first_char_such_that might_be_empty str n (fun ch => is_true (P ch)))
  : is_first_char_such_that might_be_empty str (@find_first_char_such_that Char HSLM HSL str P) (fun ch => is_true (P ch)).
Proof.
  unfold find_first_char_such_that.
  destruct H as [n H].
  set (len := length str).
  setoid_replace str with (drop (length str - len) str) at 1
    by (subst; rewrite Minus.minus_diag, drop_0; reflexivity).
  setoid_replace str with (drop (length str - len) str) in H
    by (subst; rewrite Minus.minus_diag, drop_0; reflexivity).
  assert (len <= length str) by reflexivity.
  clearbody len.
  generalize dependent str; revert n.
  induction len; simpl; intros n str IH Hlen.
  { apply first_char_such_that_0.
    rewrite drop_length.
    rewrite NPeano.Nat.sub_0_r in IH |- *.
    rewrite Minus.minus_diag.
    split.
    { apply for_first_char_nil.
      rewrite drop_length; omega. }
    { generalize dependent str.
      induction n; intros str H Hlen.
      { apply first_char_such_that_0 in H.
        rewrite drop_length, Minus.minus_diag in H.
        destruct_head and; trivial. }
      { apply first_char_such_that_past_end in H; [ | rewrite drop_length; omega ].
        left; assumption. } } }
  { pose proof (singleton_exists (take 1 (drop (length str - S len) str))) as H'.
    rewrite take_length, drop_length in H'.
    destruct H' as [ch H']; [ apply Min.min_case_strong; intros; omega | ].
    rewrite get_drop.
    rewrite (proj1 (get_0 _ _) H').
    destruct (P ch) eqn:H''.
    { apply first_char_such_that_0.
      rewrite drop_length.
      split; [ | right; omega ].
      apply (for_first_char__take 0).
      rewrite <- for_first_char_singleton by eassumption; trivial. }
    { apply is_first_char_such_that_drop.
      destruct n.
      { apply first_char_such_that_0 in IH.
        destruct IH as [IH _].
        apply (for_first_char__take 0) in IH.
        rewrite <- for_first_char_singleton in IH by eassumption; unfold is_true in *; congruence. }
      { apply is_first_char_such_that_drop in IH.
        destruct IH as [IH _].
        rewrite drop_drop in IH |- *; simpl in IH |- *.
        replace (S (length str - S len)) with (length str - len) in IH |- * by omega.
        split.
        { eapply IHlen; try eassumption; [].
          omega. }
        { apply (for_first_char__take 0).
          rewrite <- for_first_char_singleton by eassumption; congruence. } } } }
Qed.

Lemma refine_find_first_char_such_that {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}
      (str : String)
      (P : Char -> bool)
      might_be_empty
  : refine { n : nat | n <= length str
                       /\ ((exists n', is_first_char_such_that might_be_empty str n' P)
                           -> is_first_char_such_that might_be_empty str n P) }
           (ret (find_first_char_such_that str P)).
Proof.
  intros v H.
  computes_to_inv; subst.
  apply PickComputes.
  split; [ apply find_first_char_such_that_short | ].
  apply is_first_char_such_that__find_first_char_such_that.
Qed.

Section with_grammar.
  Context {HSLM : StringLikeMin Ascii.ascii}
          {HSL : StringLike Ascii.ascii}
          {HSI : StringIso Ascii.ascii}
          {HSLP : StringLikeProperties Ascii.ascii}
          {HSIP : StringIsoProperties Ascii.ascii}
          (G : pregrammar' Ascii.ascii)
          (pdata : possible_data G).

  Local Notation possible_terminals_of nt
    := (@all_possible_ascii_of_nt G pdata nt).
  Local Notation possible_terminals_of_production its
    := (@all_possible_ascii_of_production G pdata its).
  Local Notation possible_first_terminals_of nt
    := (@possible_first_ascii_of_nt G pdata nt).
  Local Notation possible_last_terminals_of nt
    := (@possible_last_ascii_of_nt G pdata nt).
  Local Notation possible_first_terminals_of_production its
    := (@possible_first_ascii_of_production G pdata its).
  Local Notation possible_last_terminals_of_production its
    := (@possible_last_ascii_of_production G pdata its).
  Local Notation might_be_empty_of nt
    := (@might_be_empty_of_pr_nt G pdata nt).
  Local Notation might_be_empty_of_production its
    := (@might_be_empty_of_pr_production G pdata its).

  Definition search_for_condition
             str its (n : nat)
    := is_first_char_such_that
         (might_be_empty_of_production its)
         str
         n
         (fun ch => list_bin ascii_beq ch (possible_first_terminals_of_production its)).

  Lemma refine_disjoint_search_for'
        {str offset len nt its}
        (H_disjoint : disjoint ascii_beq
                               (possible_terminals_of nt)
                               (possible_first_terminals_of_production its))
    : refine {splits : list nat
             | split_list_is_complete
                 G str offset len
                 (NonTerminal nt::its) splits}
             (n <- { n : nat | n <= length (substring offset len str)
                               /\ ((exists n', search_for_condition (substring offset len str) its n')
                                   -> search_for_condition (substring offset len str) its n) };
                ret [n]).
  Proof.
    intros ls H.
    computes_to_inv; subst.
    destruct H as [H0 H1].
    apply PickComputes.
    hnf; cbv zeta.
    intros Hlen it' its' Heq n ? H_reachable pit pits.
    inversion Heq; subst it' its'; clear Heq.
    left.
    pose proof (terminals_disjoint_search_for _ _ H_disjoint pit pits H_reachable) as H'.
    specialize (H1 (ex_intro _ n H')).
    pose proof (is_first_char_such_that_eq_nat_iff H1 H') as H''.
    destruct_head or; destruct_head and; subst;
      rewrite ?Min.min_r, ?Min.min_l by assumption;
      omega.
  Qed.

  Definition search_for_not_condition
             str nt its n
    := is_first_char_such_that
         (might_be_empty_of_production its)
         str
         n
         (fun ch => negb (list_bin ascii_beq ch (possible_terminals_of nt))).

  Lemma refine_disjoint_search_for_not'
        {str offset len nt its}
        (H_disjoint : disjoint ascii_beq
                               (possible_terminals_of nt)
                               (possible_first_terminals_of_production its))
    : refine {splits : list nat
             | split_list_is_complete
                 G str offset len
                 (NonTerminal nt::its)
                 splits}
             (n <- { n : nat | n <= length (substring offset len str)
                               /\ ((exists n', search_for_not_condition (substring offset len str) nt its n')
                                   -> search_for_not_condition (substring offset len str) nt its n) };
                ret [n]).
  Proof.
    intros ls H.
    computes_to_inv; subst.
    destruct H as [H0 H1].
    apply PickComputes.
    hnf; cbv zeta.
    intros Hlen it' its' Heq n ? H_reachable pit pits.
    inversion Heq; subst it' its'; clear Heq.
    left.
    pose proof (terminals_disjoint_search_for_not _ _ H_disjoint pit pits H_reachable) as H'.
    specialize (H1 (ex_intro _ n H')).
    pose proof (is_first_char_such_that_eq_nat_iff H1 H') as H''.
    destruct_head or; destruct_head and; subst;
      rewrite ?Min.min_r by assumption;
      omega.
  Qed.

  Lemma refine_disjoint_search_for
        {str offset len nt its}
        (H_disjoint : disjoint ascii_beq
                               (possible_terminals_of nt)
                               (possible_first_terminals_of_production its))
    : refine {splits : list nat
             | split_list_is_complete
                 G str offset len
                 (NonTerminal nt::its)
                 splits}
             (ret [find_first_char_such_that (substring offset len str) (fun ch => list_bin ascii_beq ch (possible_first_terminals_of_production its))]).
  Proof.
    rewrite refine_disjoint_search_for' by assumption.
    setoid_rewrite refine_find_first_char_such_that.
    simplify with monad laws; reflexivity.
  Qed.

  Lemma refine_disjoint_search_for_not
        {str offset len nt its}
        (H_disjoint : disjoint ascii_beq
                               (possible_terminals_of nt)
                               (possible_first_terminals_of_production its))
    : refine {splits : list nat
             | split_list_is_complete
                 G str offset len
                 (NonTerminal nt::its)
                 splits}
             (ret [find_first_char_such_that (substring offset len str) (fun ch => negb (list_bin ascii_beq ch (possible_terminals_of nt)))]).
  Proof.
    rewrite refine_disjoint_search_for_not' by assumption.
    setoid_rewrite refine_find_first_char_such_that.
    simplify with monad laws; reflexivity.
  Qed.

  Lemma refine_disjoint_search_for_idx
        {str offset len nt its idx}
        (Heq : default_to_production (G := G) idx = NonTerminal nt :: its)
        (H_disjoint : disjoint ascii_beq
                               (possible_terminals_of nt)
                               (possible_first_terminals_of_production its))
    : refine {splits : list nat
             | split_list_is_complete_idx
                 G str offset len
                 idx
                 splits}
             (ret [find_first_char_such_that (substring offset len str) (fun ch => list_bin ascii_beq ch (possible_first_terminals_of_production its))]).
  Proof.
    unfold split_list_is_complete_idx.
    erewrite <- refine_disjoint_search_for by eassumption.
    rewrite Heq.
    apply refine_pick_pick; intro; trivial.
  Qed.

  Lemma refine_disjoint_search_for_not_idx
        {str offset len nt its idx}
        (Heq : default_to_production (G := G) idx = NonTerminal nt :: its)
        (H_disjoint : disjoint ascii_beq
                               (possible_terminals_of nt)
                               (possible_first_terminals_of_production its))
    : refine {splits : list nat
             | split_list_is_complete_idx
                 G str offset len
                 idx
                 splits}
             (ret [find_first_char_such_that (substring offset len str) (fun ch => negb (list_bin ascii_beq ch (possible_terminals_of nt)))]).
  Proof.
    unfold split_list_is_complete_idx.
    erewrite <- refine_disjoint_search_for_not by eassumption.
    rewrite Heq.
    apply refine_pick_pick; intro; trivial.
  Qed.
End with_grammar.

Ltac solve_disjoint_side_conditions :=
  idtac;
  lazymatch goal with
  | [ |- Carriers.default_to_production (G := ?G) ?k = ?e ]
    => cbv -[Equality.ascii_beq orb andb BinNat.N.leb Reflective.opt.N_of_ascii];
       try reflexivity
  | [ |- is_true (Operations.List.disjoint _ _ _) ]
    => vm_compute; try reflexivity
  end.

Ltac replace_with_native_compute_in c H :=
  let c' := (eval native_compute in c) in
  (* By constrast [set ... in ...] seems faster than [change .. with ... in ...] in 8.4?! *)
  replace c with c' in H by (clear; native_cast_no_check (eq_refl c')).

Ltac pose_disjoint_search_for lem :=
  idtac;
  lazymatch goal with
  | [ HSLP : @StringLikeProperties _ ?HSLM ?HSL, pdata : possible_data ?G
      |- context[@ParserInterface.split_list_is_complete_idx ?Char ?G ?HSLM ?HSL ?str ?offset ?len ?idx] ]
    => pose proof (fun idx' nt its => @refine_disjoint_search_for_idx HSLM HSL HSLP G pdata str offset len nt its idx') as lem
  end.
Ltac rewrite_once_disjoint_search_for_specialize alt_side_condition_tac lem lem' :=
  idtac;
  let G := (lazymatch goal with
             | [ |- context[ParserInterface.split_list_is_complete_idx ?G ?str ?offset ?len ?idx] ]
               => G
             end) in
  match goal with
  | [ |- context[ParserInterface.split_list_is_complete_idx G ?str ?offset ?len ?idx] ]
    => pose proof (lem idx) as lem';
       do 2 (lazymatch type of lem' with
              | forall a : ?T, _ => idtac; let x := fresh in evar (x : T); specialize (lem' x); subst x
              end);
       let T := match type of lem' with forall a : ?T, _ => T end in
       let H' := fresh in
       assert (H' : T) by solve [ solve_disjoint_side_conditions | alt_side_condition_tac () ];
       specialize (lem' H'); clear H';
       cbv beta delta [id
                         all_possible_ascii_of_nt all_possible_ascii_of_production
                         possible_first_ascii_of_nt possible_first_ascii_of_production
                         possible_last_ascii_of_nt possible_last_ascii_of_production] in lem';
       do 2 (let x := match type of lem' with
                      | context[characters_set_to_ascii_list ?ls]
                        => constr:(characters_set_to_ascii_list ls)
                      end in
             replace_with_vm_compute_in x lem');
       unfold Equality.list_bin in lem';
       change (orb false) with (fun bv : bool => bv) in lem';
       cbv beta in lem';
       let T := match type of lem' with forall a : ?T, _ => T end in
       let H' := fresh in
       assert (H' : T) by solve [ solve_disjoint_side_conditions | alt_side_condition_tac () ];
       specialize (lem' H'); clear H'
  end.
Ltac rewrite_once_disjoint_search_for alt_side_condition_tac lem :=
  let lem' := fresh "lem'" in
  rewrite_once_disjoint_search_for_specialize alt_side_condition_tac lem lem';
  setoid_rewrite lem'; clear lem'.
Ltac rewrite_disjoint_search_for_no_clear alt_side_condition_tac lem :=
  pose_disjoint_search_for lem;
  progress repeat rewrite_once_disjoint_search_for alt_side_condition_tac lem.
Ltac rewrite_disjoint_search_for_with_alt alt_side_condition_tac :=
  idtac;
  let lem := fresh "lem" in
  rewrite_disjoint_search_for_no_clear alt_side_condition_tac lem;
  clear lem.
Ltac leave_side_conditions _ :=
  try rewrite disjoint_uniquize by auto using Equality.ascii_bl, Equality.ascii_lb;
  shelve.
Ltac rewrite_disjoint_search_for_leaving_side_conditions :=
  unshelve rewrite_disjoint_search_for_with_alt leave_side_conditions.
Ltac rewrite_disjoint_search_for :=
  rewrite_disjoint_search_for_with_alt ltac:(fun _ => fail).
Ltac refine_disjoint_search_for_with_alt alt_side_condition_tac :=
  idtac;
  let lem := fresh "lem" in
  pose_disjoint_search_for lem;
  let lem' := fresh "lem'" in
  rewrite_once_disjoint_search_for_specialize alt_side_condition_tac lem lem';
  refine lem'; clear lem'.
Ltac refine_disjoint_search_for_leaving_side_conditions :=
  unshelve refine_disjoint_search_for_with_alt leave_side_conditions.
Ltac refine_disjoint_search_for :=
  refine_disjoint_search_for_with_alt ltac:(fun _ => fail).


Require Import GraphBasics.Graphs.
Require Import Coq.Logic.Classical_Prop.
Require Import Verdi.Verdi.

Require Export StructTact.Fin.

Require Import ExtrOcamlBasic.
Require Import ExtrOcamlNatInt.

Require Import Verdi.ExtrOcamlBasicExt.
Require Import Verdi.ExtrOcamlList.

Load NetworkModelCommunication.

(* The user has to change this file to make it fit to their specific CDA *)

(* We assume a fixed connected graph g=(v,a). *)
Variable v : C_set.
Variable a : A_set.
Variable g : Connected v a.

(* In the general case, input and output are just some types. *)
Inductive inp: Type.
Inductive outp: Type.

(* Gives the distribution of each distribution-predicate used in the witness predicate *)
Inductive Predicate_distribution: Set:=
|and : Predicate_distribution
|or : Predicate_distribution.

(* A sub-certificate is an assigment of variables to values. *)
Variable Var: Type.
(* Design choice: Var needs to be differentiable *)
Axiom var_eq_dec : forall x y : Var, {x = y} + {x <> y}.
Variable Value: Type.
(* Design choice: Value needs to be differentiable *)
Axiom val_eq_dec : forall x y : Value, {x = y} + {x <> y}.
Inductive Assignment := assign_cons: Var ->  Value -> Assignment.
(* Design choice: variable or value difference makes the whole assignment different. *)
Axiom asign_cons_eq_dec : forall (x y : Var) (a b : Value),
  {x <> y} + {a <> b} -> assign_cons x a <> assign_cons y b.

Lemma Assignment_eq_dec : forall x y : Assignment, {x = y} + {x <> y}.
Proof.
  intros.
  destruct x, y.
  assert ({v0 = v2} + {v0 <> v2}).
  apply var_eq_dec.
  assert ({v1 = v3} + {v1 <> v3}).
  apply val_eq_dec.
  destruct H.
    destruct H0.
      left. rewrite e. rewrite e0. auto.
      right. apply asign_cons_eq_dec ; auto.
    right. apply asign_cons_eq_dec.
    left. auto.
Qed.

Lemma asign_cons_eq_dec2 : forall (x y : Var) (a b : Value),
  (x = y /\ a = b) <-> (assign_cons x a = assign_cons y b).
Proof.
  split ; intros.
    destruct H.
    subst.
    auto.
  assert (x = y \/ x <> y).
  apply classic. destruct H0. intuition.
  assert (a0 = b \/ a0 <> b).
  apply classic. destruct H0. intuition.
  assert ({x <> x} + {a0 <> b}).
  right. auto. apply asign_cons_eq_dec in H1. intuition.
  assert ({x <> y} + {a0 <> b}).
  left. auto. apply asign_cons_eq_dec in H1. intuition.
Qed.

Definition Certificate := list Assignment.

Definition val_beq (x y : Value) : bool :=
  if val_eq_dec x y then true else false.

Definition var_beq (x y : Var) : bool :=
  if var_eq_dec x y then true else false.

Lemma var_eq_refl : forall x : Var, var_beq x x = true.
Proof.
  intros.
  unfold var_beq.
  destruct (var_eq_dec).
  reflexivity.
  intuition.
Qed.

Lemma var_eq_symm : forall x y : Var, var_beq x y = var_beq y x.
Proof.
  intros.
  unfold var_beq.
  destruct (var_eq_dec).
  rewrite e.
  destruct var_eq_dec ; auto ; intuition.
  destruct var_eq_dec ; intuition.
Qed.

Lemma var_eq_diff : forall x y : Var, x <> y -> var_beq x y = false.
Proof.
  intros.
  unfold var_beq.
  destruct var_eq_dec.
  intuition.
  reflexivity.
Qed.

Definition assignment_var (assi: Assignment) :  Var :=
match assi with
  | assign_cons var value => var
end.

Definition assignment_value (assi: Assignment) :  Value :=
match assi with
  | assign_cons var value => value
end.

(* Minimal input of a network is the network itself.
 * Hence, each component me knows its neighbors in the network graph
 *)
Definition init_neighbor_l (me : Name) := (neighbors v a g (name_component me)).

(* For each sub-checker of a component me, we have to define
 * a list of sub-inputs init_inp_l,
 * a list on how to the distribution predicates are distributable init_predicate_distribution_l,
 * a list of its variables init_var_l,
 * a list of sub-outputs init_outp_l,
 * and a sub-certificate init_certificate.
 *)

Variable init_inp_l : Name -> list inp.
Variable init_predicate_distribution_l : Name -> list Predicate_distribution.
Variable init_outp_l : Name -> list outp.
Variable init_certificate : Name -> list Assignment.

Definition is_consistent (cert : Certificate) : Prop :=
  forall (assign1 assign2 : Assignment),
    let (var1, val1) := assign1 in
      let (var2, val2) := assign2 in
        In assign1 cert -> In assign2 cert ->
          var1 = var2 -> val1 = val2.

(* These axioms are to be sure the initialisation of the network doesn't break the consistency
_within_ each checker. Therefore the initial certificate has to be consistent and the var_l
has to be correctly initialized. *)

Axiom init_certificate_is_consistent : forall Name,
  is_consistent (init_certificate Name).

(* initialisation of a sub-checker;
 * knowledge a sub-checker has even before the cda computed and terminated *)
Record Checkerknowledge : Type := mk_Checkerknowledge {
  inp_l : list inp;
  Predicate_distribution_l: list Predicate_distribution;
  neighbor_l: list Component
}.

Definition init_Checkerknowledge (me : Name) :=
  mk_Checkerknowledge (init_inp_l me) (init_predicate_distribution_l me) (init_neighbor_l me).

(* a sub-checker gets the sub-output and sub-certificate of its component after the cda computed and terminated *)
Record Checkerinput : Type := mk_Checkerinput{
  outp_l : list outp;
  certificate : list Assignment
}.

Definition init_Checkerinput (me : Name) : Checkerinput :=
  mk_Checkerinput (init_outp_l me) (init_certificate me).


Require Import Coq.Setoids.Setoid.
Require Import Coq.Lists.List.

Require Import Tactics.
Require Import Relation.
Require Import Syntax.
Require Import SimpSub.
Require Import Dynamic.
Require Import Equivalence.
Require Import Equivalences.
Require Import Hygiene.
Require Import Morphism.
Require Import Defined.
Require Rules.
Require Defs.

Lemma subst_leqtp :
  forall object (s : @sub object), subst s leqtp = leqtp.
Proof.
prove_subst.
Qed.

Hint Rewrite subst_leqtp : subst.

Ltac prove_the_hygiene :=
  repeat
    (match goal with
     | Hh : hygiene _ _ |- _ =>
         let H := fresh
         in
           so (hygiene_invert_auto _#5 Hh) as H; cbn in H; clear Hh; destruct_all H
     end);
  repeat (apply hygiene_auto; cbn; repeat split); auto;
  first [apply hygiene_var | apply hygiene_shift' | idtac]; auto.

Lemma def_alltp :
  forall a, equiv (app Defs.foralltp (lam a)) (alltp a).
Proof.
intros a.
unfold Defs.foralltp.
eapply equiv_trans.
  {
  apply steps_equiv.
  eapply star_step.
    {
    apply step_app2.
    }
  apply star_refl.
  }

  {
  simpsub.
  cbn [Nat.add].
  apply equiv_alltp.
  apply steps_equiv.
  eapply star_step.
    {
    apply step_app2.
    }

    {
    simpsub.
    rewrite -> subst_var0_sh1.
    apply star_refl.
    }
}
Qed.

Lemma def_arrow :
  forall a b,
    equiv (app (app Defs.arrow a) b) (pi a (subst sh1 b)).
Proof.
intros a m.
unfold Defs.arrow.
apply steps_equiv.
eapply star_step.
  {
  apply step_app1.
  apply step_app2.
  }
simpsub.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Lemma def_guard :
  forall a b,
    equiv (app (app Defs.guard a) b) (guard a b).
Proof.
intros a b.
unfold Defs.guard.
apply steps_equiv.
eapply star_step.
  {
  apply step_app1.
  apply step_app2.
  }
simpsub.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Lemma def_eeqtp :
  forall a b,
    equiv (app (app Defs.eeqtp a) b) (prod (subtype a b) (subtype b a)).
Proof.
intros a b.
unfold Defs.eeqtp.
apply steps_equiv.
eapply star_step.
  {
  apply step_app1.
  apply step_app2.
  }
simpsub.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Lemma def_eq :
  forall a m n,
    equiv (app (app (app Defs.eq a) m) n) (equal a m n).
Proof.
intros a m n.
unfold Defs.eq.
apply steps_equiv.
eapply star_step.
  {
  apply step_app1.
  apply step_app1.
  apply step_app2.
  }
simpsub.
eapply star_step.
  {
  apply step_app1.
  apply step_app2.
  }
simpsub.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Lemma def_eqtp :
  forall a b,
    equiv (app (app Defs.eqtp a) b) (eqtype a b).
Proof.
intros a b.
unfold Defs.eqtp.
apply steps_equiv.
eapply star_step.
  {
  apply step_app1.
  apply step_app2.
  }
simpsub.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Lemma def_iexists :
  forall i k a,
    equiv (app (app (app Defs.iexists i) k) (lam a)) (exist i k a).
Proof.
intros i k a.
unfold Defs.iexists.
eapply equiv_trans.
  {
  apply steps_equiv.
  eapply star_step.
    {
    apply step_app1.
    apply step_app1.
    apply step_app2.
    }
  simpsub.
  eapply star_step.
    {
    apply step_app1.
    apply step_app2.
    }
  simpsub.
  eapply star_step.
    {
    apply step_app2.
    }
  simpsub.
  apply star_refl.
  }
apply equiv_exist; auto using equiv_refl.
apply steps_equiv.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl'.
rewrite <- eqsub_expand_id.
simpsub.
reflexivity.
Qed.

Lemma def_iforall :
  forall i k a,
    equiv (app (app (app Defs.iforall i) k) (lam a)) (all i k a).
Proof.
intros i k a.
unfold Defs.iforall.
eapply equiv_trans.
  {
  apply steps_equiv.
  eapply star_step.
    {
    apply step_app1.
    apply step_app1.
    apply step_app2.
    }
  simpsub.
  eapply star_step.
    {
    apply step_app1.
    apply step_app2.
    }
  simpsub.
  eapply star_step.
    {
    apply step_app2.
    }
  simpsub.
  apply star_refl.
  }
apply equiv_all; auto using equiv_refl.
apply steps_equiv.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl'.
rewrite <- eqsub_expand_id.
simpsub.
reflexivity.
Qed.

Lemma def_inl :
  forall m,
    equiv (app Defs.inl m) (sumleft m).
Proof.
intros m.
unfold Defs.inl.
eapply steps_equiv.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Lemma def_inr :
  forall m,
    equiv (app Defs.inr m) (sumright m).
Proof.
intros m.
unfold Defs.inl.
eapply steps_equiv.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Lemma def_intersect :
  forall a b,
    equiv (app (app Defs.intersect a) (lam b)) (intersect a b).
Proof.
intros a m.
unfold Defs.intersect.
eapply equiv_trans.
  {
  apply steps_equiv.
  eapply star_step.
    {
    apply step_app1.
    apply step_app2.
    }
  simpsub.
  eapply star_step.
    {
    apply step_app2.
    }
  simpsub.
  apply star_refl.
  }
apply equiv_intersect; auto using equiv_refl.
apply steps_equiv.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl'.
rewrite <- eqsub_expand_id.
simpsub.
reflexivity.
Qed.

Lemma def_istp :
  forall a,
    equiv (app Defs.istp a) (eqtype a a).
Proof.
intros a.
unfold Defs.istp.
apply steps_equiv.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Lemma def_karrow :
  forall a b,
    equiv (app (app Defs.karrow a) b) (karrow a b).
Proof.
intros a m.
unfold Defs.karrow.
apply steps_equiv.
eapply star_step.
  {
  apply step_app1.
  apply step_app2.
  }
simpsub.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Lemma def_kind :
  forall i,
    equiv (app Defs.kind i) (kuniv i).
Proof.
intros i.
unfold Defs.kind.
apply steps_equiv.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Lemma def_level : Defs.level = nattp.
Proof.
auto.
Qed.

Lemma def_letnext :
  forall m n,
    equiv (app (app Defs.letnext m) (lam n)) (subst1 (prev m) n).
Proof.
intros m n.
unfold Defs.letnext.
apply steps_equiv.
eapply star_trans.
  {
  eapply star_step.
    {
    apply step_app1.
    apply step_app2.
    }
  simpsub.
  eapply star_step.
    {
    apply step_app2.
    }
  simpsub.
  apply star_refl.
  }
apply star_one.
apply step_app2.
Qed.

Lemma def_lsucc :
  forall m, equiv (app Defs.lsucc m) (nsucc m).
Proof.
intro m.
unfold Defs.lsucc.
eapply equiv_trans.
  {
  apply steps_equiv.
  apply star_one.
  apply step_app2.
  }
simpsub.
rewrite -> def_inr.
apply equiv_refl.
Qed.

Lemma def_lzero :
  equiv Defs.lzero Defined.nzero.
Proof.
unfold Defs.lzero.
unfold Defined.nzero.
rewrite -> def_inl.
unfold Defined.sumleft.
apply equiv_refl.
Qed.

Lemma def_mu :
  forall a, equiv (app Defs.mu (lam a)) (mu a).
Proof.
intros a.
unfold Defs.mu.
eapply equiv_trans.
  {
  apply steps_equiv.
  eapply star_step.
    {
    apply step_app2.
    }
  apply star_refl.
  }

  {
  simpsub.
  cbn [Nat.add].
  apply equiv_mu.
  apply steps_equiv.
  eapply star_step.
    {
    apply step_app2.
    }

    {
    simpsub.
    rewrite -> subst_var0_sh1.
    apply star_refl.
    }
}
Qed.

Lemma def_nat : eq Defs.nat nattp.
Proof.
auto.
Qed.

Lemma def_negative :
  forall a,
    equiv
      (app Defs.negative (lam a))
      (isnegative a).
Proof.
intros a.
unfold Defs.negative.
eapply equiv_trans.
  {
  apply steps_equiv.
  eapply star_step.
    {
    apply step_app2.
    }
  apply star_refl.
  }

  {
  simpsub.
  cbn [Nat.add].
  apply equiv_isnegative.
  apply steps_equiv.
  eapply star_step.
    {
    apply step_app2.
    }
  simpsub.
  rewrite -> subst_var0_sh1.
  apply star_refl.
  }
Qed.

Lemma def_of :
  forall a m,
    equiv (app (app Defs.of a) m) (equal a m m).
Proof.
intros a m.
unfold Defs.of.
apply steps_equiv.
eapply star_step.
  {
  apply step_app1.
  apply step_app2.
  }
simpsub.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Lemma def_pi :
  forall a b,
    equiv (app (app Defs.pi a) (lam b)) (pi a b).
Proof.
intros a m.
unfold Defs.pi.
eapply equiv_trans.
  {
  apply steps_equiv.
  eapply star_step.
    {
    apply step_app1.
    apply step_app2.
    }
  simpsub.
  eapply star_step.
    {
    apply step_app2.
    }
  simpsub.
  apply star_refl.
  }
apply equiv_pi; auto using equiv_refl.
apply steps_equiv.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl'.
rewrite <- eqsub_expand_id.
simpsub.
reflexivity.
Qed.

Lemma def_positive :
  forall a,
    equiv
      (app Defs.positive (lam a))
      (ispositive a).
Proof.
intros a.
unfold Defs.positive.
eapply equiv_trans.
  {
  apply steps_equiv.
  eapply star_step.
    {
    apply step_app2.
    }
  apply star_refl.
  }

  {
  simpsub.
  cbn [Nat.add].
  apply equiv_ispositive.
  apply steps_equiv.
  eapply star_step.
    {
    apply step_app2.
    }
  simpsub.
  rewrite -> subst_var0_sh1.
  apply star_refl.
  }
Qed.

Lemma def_set :
  forall a b,
    equiv (app (app Defs.set a) (lam b)) (set a b).
Proof.
intros a m.
unfold Defs.set.
eapply equiv_trans.
  {
  apply steps_equiv.
  eapply star_step.
    {
    apply step_app1.
    apply step_app2.
    }
  simpsub.
  eapply star_step.
    {
    apply step_app2.
    }
  simpsub.
  apply star_refl.
  }
apply equiv_set; auto using equiv_refl.
apply steps_equiv.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl'.
rewrite <- eqsub_expand_id.
simpsub.
reflexivity.
Qed.

Lemma def_sigma :
  forall a b,
    equiv (app (app Defs.sigma a) (lam b)) (sigma a b).
Proof.
intros a m.
unfold Defs.sigma.
eapply equiv_trans.
  {
  apply steps_equiv.
  eapply star_step.
    {
    apply step_app1.
    apply step_app2.
    }
  simpsub.
  eapply star_step.
    {
    apply step_app2.
    }
  simpsub.
  apply star_refl.
  }
apply equiv_sigma; auto using equiv_refl.
apply steps_equiv.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl'.
rewrite <- eqsub_expand_id.
simpsub.
reflexivity.
Qed.

Lemma def_subtype :
  forall a b,
    equiv (app (app Defs.subtype a) b) (subtype a b).
Proof.
intros a b.
unfold Defs.subtype.
apply steps_equiv.
eapply star_step.
  {
  apply step_app1.
  apply step_app2.
  }
simpsub.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Lemma def_sum :
  forall a b,
    equiv (app (app Defs.sum a) b) (sumtype a b).
Proof.
intros a b.
unfold Defs.sum.
eapply equiv_trans.
  {
  apply equiv_app; [| apply equiv_refl].
  apply steps_equiv.
  apply star_one.
  apply step_app2.
  }
simpsub.
apply steps_equiv.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Lemma def_sumcase :
  forall m n p,
    equiv
      (app (app (app Defs.sumcase m) (lam n)) (lam p))
      (sumcase m n p).
Proof.
intros m n p.
unfold Defs.sumcase.
eapply equiv_trans.
  {
  apply equiv_app; [| apply equiv_refl].
  eapply equiv_trans.
    {
    apply equiv_app; [| apply equiv_refl].
    apply steps_equiv.
    apply star_one.
    apply step_app2.
    }
  simpsub.
  apply steps_equiv.
  apply star_one.
  apply step_app2.
  }
simpsub.
rewrite -> equiv_beta.
simpsub.
rewrite -> !equiv_beta.
simpsub.
unfold sumcase.
apply equiv_refl.
Qed.

Lemma def_tarrow :
  forall a b,
    equiv (app (app Defs.tarrow a) b) (arrow a b).
Proof.
intros a m.
unfold Defs.arrow.
apply steps_equiv.
eapply star_step.
  {
  apply step_app1.
  apply step_app2.
  }
simpsub.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Lemma def_univ :
  forall i,
    equiv (app Defs.univ i) (univ i).
Proof.
intros i.
unfold Defs.univ.
apply steps_equiv.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Lemma def_prod : forall a b,
    equiv (app (app Defs.prod a) b) (prod a b).
Proof.
intros a m.
unfold Defs.prod.
apply steps_equiv.
eapply star_step.
  {
  apply step_app1.
  apply step_app2.
  }
simpsub.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Lemma def_fut : forall a,
    equiv (app Defs.future a) (fut a).
Proof.
intros a.
unfold Defs.future.
  apply steps_equiv.
  eapply star_step.
  {
    apply step_app2.
  }
  {
    simpsub.
    apply star_refl.
  }
Qed.

Lemma def_rec : forall a,
    equiv (app Defs.rec (lam a)) (rec a).
Proof.
intros a.
unfold Defs.rec.
eapply equiv_trans.
{
  apply steps_equiv.
  eapply star_step.
  apply step_app2.
  apply star_refl.
}
{
  simpsub. simpl.
  apply equiv_rec.
  apply steps_equiv.
  eapply star_step.
  { apply step_app2. }
  {
    simpsub.
    replace (subst (dot (var 0) sh1) a) with a.
    { apply star_refl. }
    { replace a with (subst id a) at 1.
    apply subst_eqsub. apply eqsub_expand_sh.
    simpsub; auto. }
  }
}
Qed.

Lemma def_squash :
  forall a,
    equiv (app Defs.squash a) (squash a).
Proof.
intros a.
unfold Defs.squash.
apply steps_equiv.
eapply star_step.
  {
  apply step_app2.
  }

  {
  simpsub.
  apply star_refl.
  }
Qed.

Lemma def_ite: forall m p r, equiv (app (app (app Defs.ite m) p) r) (bite m p r).
intros m p r.
unfold Defs.ite.
    apply steps_equiv.
    eapply star_step.
    - do 2 apply step_app1. apply step_app2.
    - simpsub. eapply star_step.
      + apply step_app1. apply step_app2.
      + simpsub. eapply star_step.
        * apply step_app2.
        * simpsub. auto. apply star_refl.
Qed.

Lemma equiv_to_equivh {m m'} : @equiv Rules.obj m m' -> equivh (hyp_tm m) (hyp_tm m') /\
                                                  equivh (hyp_tml m) (hyp_tml m')
.
  intros Hequiv.
  split; try (constructor; assumption);
  intros P; split; intros Hctx_hyg; constructor; apply Hhyg;
            inversion Hctx_hyg; subst; assumption.
Qed.

Lemma def_sigmah: forall a b,
    equivh (hyp_tm (app (app Defs.sigma a) (lam b)))
            (hyp_tm (sigma a b)).
  intros a b.
  apply (equiv_to_equivh (def_sigma a b)).
Qed.

Lemma def_prodh: forall a b,
    equivh (hyp_tm (app (app Defs.prod a) b))
            (hyp_tm (prod a b)).
  intros a b.
  apply (equiv_to_equivh (def_prod a b)).
Qed.

Lemma def_futh: forall a,
    equivh (hyp_tm (app Defs.future a))
            (hyp_tm (fut a)).
  intros a.
  apply (equiv_to_equivh (def_fut a)).
Qed.

Lemma def_kindh_l: forall i,
    equivh (hyp_tml (app Defs.kind i))
            (hyp_tml (kuniv i)).
  intros i.
  apply (equiv_to_equivh (def_kind i)).
Qed.

Lemma def_univh_l: forall i,
    equivh (hyp_tml (app Defs.univ i))
            (hyp_tml (univ i)).
  intros i.
  apply (equiv_to_equivh (def_univ i)).
Qed.


Require Export Mtac.Mtac.
Import MtacNotations.

Require Import List.
Import ListNotations.

Module ListMtactics.

  Definition NotFound : Exception.
    exact exception.
  Qed.

  Definition inlist {A} (x : A) :=
    mfix1 f (s : list A) : M _ :=
      mmatch s as s' return M (In x s') with
      | [? l r] l ++ r =>
        mtry
          il <- f l;
          ret (in_or_app l r x (or_introl il))
        with NotFound =>
          ir <- f r;
          ret (in_or_app l r x (or_intror ir))
        end
      | [? s'] (x :: s') => ret (in_eq _ _)
      | [? y s'] (y :: s') =>
        r <- f s';
        ret (in_cons y _ _ r)
      | _ => raise NotFound
      end.

  Definition find {A} {B : A -> Type} (x : A) :=
    mfix1 f (s : list (sigT B)) : M (B x) :=
      mmatch s with
      | [? l r] l ++ r =>
        mtry
          f l
        with NotFound =>
          f r
        end
      | [? y s'] (existT B x y :: s') => ret y
      | [? y s'] (y :: s') => f s'
      | _ => raise NotFound
      end.

  Definition remove {A} {B : A -> Type} (x : A) :=
    mfix1 f (s : list (sigT B)) : M (list (sigT B)) :=
      mmatch s with
      | [? y s'] (existT B x y :: s') => ret s'
      | [? y s'] (y :: s') => r <- f s'; ret (y :: r)
      | _ => raise NotFound
      end.

  Fixpoint iter {A:Type} (f : A -> M unit) (l : list A) : M unit :=
    match l with
    | [] => ret tt
    | (a :: l') => f a;; iter f l'
    end.

End ListMtactics.

Set Implicit Arguments.

Definition AssumptionNotFound {T} (x : T) : Exception. exact exception. Qed.
Definition assumption {P : Type} : M P :=
  hs <- hypotheses;
  let f := mfix1 f (s : list Hyp) : M P :=
    mmatch s return M P with
    | [? (x:P) t s'] (@ahyp P x t :: s') => ret x
    | [? a s'] (a :: s') => f s'
    | _ => raise (AssumptionNotFound P)
    end
  in f hs.

(** Tactic to unify two terms [x] and [y]. *)
Definition NotUnifiableException : Exception. exact exception. Qed.
Program Definition unify A (x y : A) (P : A -> Type) (f : x = y -> P y) : M (P x) :=
    a <- mmatch x as x' return M (x = x' -> P x') with
         | y => ret (fun H => f H)
         | _ => raise NotUnifiableException
         end;
    retS (a (eq_refl _)).
Arguments unify {A} x y P f.

Definition CantApply {T1 T2} (x:T1) (y:T2) : Exception. exact exception. Qed.
Definition apply {P T} (l : T) : M P :=
  (mfix2 app (T : _) (l' : T) : M P :=
    mtry unify P T (fun a=>a) (fun _ => l')
    with NotUnifiableException =>
      mmatch T return M P with
      | [? T1 T2] (forall x:T1, T2 x) => [H]
          e <- evar T1;
          l' <- retS (eq_rect_r (fun T => T -> T2 e)
            (fun l : forall x : T1, T2 x => l e) H l');
          app (T2 e) l'
      | _ => raise (CantApply P l)
      end
    end) _ l.

Definition eapply {P T} (l : T)  :=
  (mfix3 app (T : _) (l' : T) (es : list dyn) : M (P * list dyn)%type :=
    mtry unify P T (fun a=>(a*list dyn)%type) (fun _ => (l', es))
    with NotUnifiableException =>
      mmatch T with
      | [? T1 T2] T1 -> T2 => [H]
          e <- evar T1;
          l' <- retS (eq_rect_r (fun T => T -> T2)
            (fun l : T1 -> T2 => l e) H l');
          app T2 l' (Dyn _ e :: es)
      | [? T1 T2] (forall x:T1, T2 x) => [H]
          e <- evar T1;
          l' <- retS (eq_rect_r (fun T => T -> T2 e)
            (fun l : forall x : T1, T2 x => l e) H l');
          app (T2 e) l' es
      | _ => raise (CantApply P l)
      end
    end) _ l [].

Fixpoint try_all (t : forall T, T -> M unit)  ls :=
  match ls with
  | [] => ret tt
  | (Dyn _ e :: ls') =>
    b <- is_evar e;
    if b then t _ e;; try_all t ls' else try_all t ls'
  end.

Definition eassumption (T : Type) (e:T) :=
  r <- @assumption T;
  mmatch r with e => ret tt | _ => raise exception end.

Definition try_once_each_constr {P} T (x : T) : M P :=
  cs <- constrs x;
  (fix f (cs : list dyn) : M P :=
    match cs with
    | [] => evar _
    | (Dyn _ c :: cs') =>
      mtry
        ps <- eapply c;
        ass <- retS (rev (snd ps));
        try_all eassumption ass;;
        ret (fst ps)
      with _ => f cs' end
    end) cs.

Lemma uncurry P Q R : (P /\ Q -> R) -> P -> Q -> R.
Proof. tauto. Qed.

Lemma curry (P Q R : Prop) : (P -> Q -> R) -> P /\ Q -> R.
Proof. tauto. Qed.

Lemma orE (P Q R : Prop) : (P -> R) -> (Q -> R) -> P \/ Q -> R.
Proof. tauto. Qed.

Program Definition tauto0 :=
  mfix1 f (P : Prop) : M (P : Prop) :=
    mmatch P as P' return M (P' : Prop) with
    | True => ret I
    | [? R Q] R /\ Q =>
      r1 <- f R;
      r2 <- f Q;
      ret (conj r1 r2)
    | [? R Q] R \/ Q =>
      mtry
        r <- f R;
        ret (or_introl Q r)
      with [? T (x:T)] AssumptionNotFound x =>
        r <- f Q;
        ret (or_intror R r)
      end
    | [? R Q T : Prop] (R /\ Q -> T) =>
      r <- f (R -> Q -> T);
      ret (curry r)
    | [? R Q T : Prop] (R \/ Q -> T) =>
      r1 <- f (R -> T);
      r2 <- f (Q -> T);
      ret (orE r1 r2)
    | [? R Q : Prop] R -> Q =>
      nu (x : R),
        r <- f Q;
        abs x r
    | [? R (Q : R -> Prop)] forall x: R, Q x =>
      nu (x : R),
        r <- f (Q x);
        abs x r
    | [? A (q:A -> Prop)] (exists x : A, q x) =>
        X <- evar A;
        r <- f (q X);
        ret (ex_intro q X r)
    | _ => assumption
    end.

Definition CannotFillImplicits : Exception. exact exception. Qed.

Definition fill_implicits {A B} (x : A) : M B :=
  let rec :=
    mfix3 f (n : nat) (A' : Type) (x' : A') : M B :=
      match n with
      | 0 => raise CannotFillImplicits
      | S n' =>
        mmatch A' with
        | B => [H] retS (eq_rect A' id x' B H) : M B
        | [? (T : Type) (P : T -> Type)] forall y:T, P y =c> [H]
          nu z : T,
            e <- evar T;
            f n' _ (eq_rect A' id x' (forall y:T, P y) H e)
        | _ => raise exception
        end
      end
  in rec 10 _ x.

Notation "f ?" := (eval (fill_implicits f)) (at level 0).

Definition munify A (x y : A) (P : A -> Type) (f : x = y -> M (P y)) : M (P x)
  := mmatch x with y => [H] f H | _ => raise NotUnifiableException end.
Arguments munify {A} x y P f.

Definition open_pattern {A} {P:A->Type} {t:A}  :=
  mfix1 op (p : tpatt A P t) : M (tpatt A P t) :=
    match p return M _ with
    | base x f u => ret p : M (tpatt _ _ _)
    | @tele A' B' C t' f =>
      e <- evar C;
      munify (tpatt A' B' t') (tpatt A P t) (fun _ => tpatt A P t)
      (fun H => op (match H in (_ = y) return y with
                      | eq_refl => (f e)
                    end ))
    end.

Definition NoPatternMatches : Exception. exact exception. Qed.
Fixpoint mmatch' A P t (ps : list (tpatt A P t)) : M (P t) :=
  match ps with
  | [] => raise NoPatternMatches
  | (p :: ps') =>
    p' <- open_pattern p;
    mtry
      match p' with
      | @base A P t t' f u =>
        munify t t' P f : M (P t)
      | _ => raise NotUnifiableException
      end
    with NotUnifiableException =>
      mmatch' ps'
    end
  end.
Arguments mmatch' {A} {P} t ps.

Definition eopen_pattern {A} {P:A->Type} {t:A}  :=
  mfix2 op (p : tpatt A P t) (ls : list dyn) : M (list dyn * tpatt A P t)%type :=
    match p return M _ with
    | base x f u => ret (ls, p) : M (list dyn * tpatt _ _ _)
    | @tele A' B' C t' f =>
      e <- evar (C : Type);
      mmatch tpatt A' B' t' with
      | tpatt A P t => [H] op (match H in (_ = y) return y with
                               | eq_refl => (f e)
                               end ) (Dyn _ e :: ls)
      end
    end.
Arguments eopen_pattern {A} {P} {t} x1 x2.
Set Printing Universes.

Definition match_goal {A:Type} {P:A->Type} (t : A) (p : tpatt A P t)
: M (list dyn * P t) :=
  pes <- eopen_pattern p [];
  let (ls, goal) := pes : (list dyn * tpatt _ _ _)%type in
  mmatch goal with
  | [? f u] @base A P t t f u =>
    pf <- (f eq_refl) : M (P t);
    ret (ls, pf)
  end.

Arguments match_goal _ _ _ p%mtac_patt.
Notation "'mmatch' x ls" := (mmatch' x ls).
Definition inl' A (x : A) : forall l : list A, M (In x l) :=
  mfix1 f (l : list A) : M (In x l) :=
  mmatch l with
  | [? s] (x :: s) => ret in_eq?
  | [? y s] (y :: s) => r <- f s; ret (in_cons y _ _ r)
  | _ => raise exception
  end.

Definition intro {A : Type} {P: A -> Type} (f : forall x:A, M (P x))
  : M (forall x:A, P x)
  := nu x:A, r <- f x; abs x r.

Definition LMap {A B} (f : A -> M B) :=
  mfix1 rec (l : list A) : M (list B) :=
  match l with
  | [] => ret []
  | (x :: xs) => l <- rec xs;
                b <- f x;
                ret (b :: l)
  end.

Definition CantCoerce : Exception. exact exception. Qed.

Definition coerce {A B : Type} (x : A) : M B :=
  mmatch A return M B with
  | B => [H] ret (eq_rect_r _ (fun x0 : B => x0) H x)
  | _ => raise CantCoerce
  end.

Program Definition copy_ctx {A} (B : A -> Type) :=
  mfix1 rec (d : dyn) : M Type :=
  mmatch d with
  | [? C (D : C -> Type) (E : forall y:C, D y)] {| elem := fun x : C=>E x |} =>
    nu y : C,
      r <- rec (Dyn _ (E y));
      pabs y r
  | [? c : A] {| elem := c |} =>
    ret (B c)
  end.

Definition destruct {A : Type} (n : A) {P : A -> Prop} : M (P n) :=
  l <- constrs A;
  l <- LMap (fun d : dyn=>
             t' <- copy_ctx P d;
             e <- evar t';
             ret {| elem := e |}) l;
  let c := {| case_ind := A;
              case_val := n;
              case_type := P n;
              case_return := {| elem := fun n : A => P n |};
              case_branches := l
           |} in
  d <- makecase c;
  d <- coerce (elem d);
  ret d.

Goal forall n : nat, True.
  intro n.
  Set Printing Implicit.
  rrun (destruct n).
  Unshelve.
  simpl.
  apply I.
  intro n'.
  simpl.
Abort.

(*
This is a proposal for a different kind of goal handling than the one attempted by Thomas. Given the difficulty to maintain Ocaml code free of bugs, the proposal is to keep as much code on the Coq side as possible. This is in accordance to #2. In this proposal, goals are just evars that are registered as goals. At a given point one can access the local context (hypotheses).

The primitives in Mtac2 can be the following:
```Coq
registerGoal {A:Type} : A -> Mtac2 unit
unregisterGoal {A:Type} : A -> Mtac2 unit
goals : Mtac2 (list dyn)
hypotheses : Mtac2 (list dyn)
```

The high-level idea is that the current goal will be passed along the tactics. For instance, the intro tactic

Then, for refining a goal we can just use the primitive for unification (see #2). For instance, the apply tactic can be written as follow:
```Coq
Definition apply {P T} (l : T) : M P :=
  (mfix2 app (T : _) (l' : T) : M P :=
    mtry unify P T (fun a=>a) (fun _ => l')
    with NotUnifiableException =>
      mmatch T return M P with
      | [? T1 T2] (forall x:T1, T2 x) => [H]
          e <- evar T1;
          registerGoal e;
          l' <- retS (eq_rect_r (fun T => T -> T2 e)
            (fun l : forall x : T1, T2 x => l e) H l');
          app (T2 e) l'
      | _ => raise (CantApply P l)
      end
    end) _ l.
```
Then, a tactical like ";" can take the list of goals and pass them to the list of tactics. Note that each time we create a new goal, it has its local context mapped to the current one. This will maintain the current Ltac semantics. For instance, a tactic like the following, in the context where ```x``` is a natural number will generate two "goals" with the second one in an extended context (intros is just using the nu operator).
```Coq
case x; [ | intros n ]; reflexivity
```

There is an issue with the
*)
Example test (x : nat) (y : nat) (H : x > y) : x > y.
rrun (p <- match_goal ([? a] a => @assumption a)%mtac_patt; ret (snd p)).
Qed.
(*
match goal with
| [u:nat, v:nat, H : ?v > ?u |- _] => idtac v; apply I
end.

*)


Require Export FiatFormal.Language.TyEnv.
Require Export FiatFormal.Language.Ty.
Require Export FiatFormal.Language.Ki.

(* Expressions *)
Inductive exp : Type :=
 | XVar  : nat -> exp               (* deBruijn indices *)
 | XApp  : exp -> exp -> exp       (* Value application *)
 | XTup   : list exp -> exp       (* Arity n tuples *)
 | XProj  : nat -> exp -> exp        (* Projection *)
 | XNFun  : list ty -> exp -> exp  (* Arity n functions *)
 | XNApp  : exp -> list exp -> exp (* Arity n application *)
 | XFix   : ty -> ty -> exp -> exp  (* Fixpoint *)
 (* Data Types *)
 | XCon   : datacon -> list exp -> exp       (* Data constructor *)
 | XMatch : exp     -> list alt -> exp       (* Match statement *)
 | XChoice : ty -> propcon -> list exp -> exp (* Non-deterministic choice operator *)

 (* Alternatives *)
with alt     : Type :=
 | AAlt   : datacon -> list ty  -> exp -> alt (* Branches of a match statement *).

Hint Constructors alt.
Hint Constructors exp.

(* Get the data constructor of an alternative. *)
Fixpoint dcOfAlt (aa: alt) : datacon :=
 match aa with
 | AAlt dc _ _ => dc
 end.
Hint Unfold dcOfAlt.

(* Get the alternative body that matches a given constructor. *)
Fixpoint getAlt (dc: datacon) (alts: list alt) {struct alts}
                : option alt :=
 match alts with
 |  nil  => None

 |  AAlt dc' tsArgs x :: alts'
 => if datacon_beq dc dc'
     then Some (AAlt dc' tsArgs x)
     else getAlt dc alts'
 end.

(* If we get a single alternative from a list,  *)
(*    then that alternative was in the list. *)
Lemma getAlt_in
 :  forall dc alt alts
 ,  getAlt dc alts = Some alt
 -> In alt alts.
Proof.
 intros.
 induction alts.
  false.
  destruct a as [dc' tsArgs x].
  simpl in H.
  breaka (datacon_beq dc dc').
   inverts H.
   apply datacon_beq_eq in HeqX; auto.
Qed.

(* Given a data constructor, if one of the alternatives in a  *)
(*    list matches that data constructor then we can get the other *)
(*    information about the alternative from the list. *)
Lemma getAlt_exists
 :  forall d alts
 ,  In d (map dcOfAlt alts)
 -> (exists tsArgs x, getAlt d alts = Some (AAlt d tsArgs x)).
Proof.
 intros.
 induction alts.
  simpl in H. false.
  simpl in H. inverts H.
   destruct a. simpl.
   breaka (datacon_beq d d).
    exists l. exists e. auto.
    apply datacon_beq_false in HeqX. false.
   lets D: IHalts H0.
   destruct a. simpl.
    breaka (datacon_beq d d0).
     apply datacon_beq_eq in HeqX. subst. auto.
     exists l. exists e. auto.
Qed.

(********************************************************************)
(* Mutual induction principle for expressions.
   As expressions are indirectly mutually recursive with lists,
   Coq's Combined scheme command won't make us a strong enough
   induction principle, so we need to write it out by hand. *)

Theorem exp_mutind
 : forall
    (PX : exp -> Prop)
    (PA : alt -> Prop)
 ,  (forall n,                                PX (XVar n))
 -> (forall x1 x2,   PX x1 -> PX x2        -> PX (XApp x1 x2))
 -> (forall xs,      Forall PX xs         -> PX (XTup xs))
 -> (forall n x,     PX x                 -> PX (XProj n x))
 -> (forall ts x,    PX x                 -> PX (XNFun ts x))
 -> (forall x xs,    PX x -> Forall PX xs  -> PX (XNApp x xs))
 -> (forall t1 t2 x, PX x                 -> PX (XFix t1 t2 x))
 -> (forall dc xs,   Forall PX xs         -> PX (XCon dc xs))
 -> (forall x  aa,   PX x  -> Forall PA aa -> PX (XMatch x aa))
 -> (forall t pc xs, Forall PX xs         -> PX (XChoice t pc xs))
 -> (forall dc ts x, PX x                 -> PA (AAlt dc ts x))
 ->  forall x, PX x.
Proof.
  intros PX PA.
  intros var app tup proj nfun napp ffix con mmatch proof alt.
  refine (fix  IHX x : PX x := _
            with IHA a : PA a := _
                                   for  IHX).
  (* expressions *)
  case x; intros.

  Case "XVar".
  apply var.

  Case "XApp".
  apply app.
  apply IHX.
  apply IHX.

  Case "XTup".
  apply tup.
  induction l; intuition.

  Case "XProj".
  apply proj.
  apply IHX.

  Case "XNFun".
  apply nfun.
  apply IHX.

  Case "XNApp".
  apply napp.
  apply IHX.
  induction l; intuition.

  Case "XFix".
  apply ffix.
  apply IHX.

  Case "XCon".
  apply con.
  induction l; intuition.

  Case "XMatch".
  apply mmatch.
  apply IHX.
  induction l; intuition.

  Case "XCon".
  apply proof.
  induction l; intuition.

  (* alternatives *)
  case a; intros.

  Case "XAlt".
  apply alt.
  apply IHX.
Qed.

(* This is used in our modified statement
   of progress for expressions. *)
Inductive hasChoiceX : exp -> Prop :=
| HcApp1  : forall x1 x2,
    hasChoiceX x1
    -> hasChoiceX (XApp x1 x2)
| HcApp2  : forall x1 x2,
    hasChoiceX x2
    -> hasChoiceX (XApp x1 x2)
| HcTup   : forall xs,
    Exists (hasChoiceX) xs
    -> hasChoiceX (XTup xs)
| HcProj  : forall x n,
    hasChoiceX x
    -> hasChoiceX (XProj n x)
| HcNFun  : forall ts x,
    hasChoiceX x
    -> hasChoiceX (XNFun ts x)
| HcNApp1  : forall x xs,
    hasChoiceX x
    -> hasChoiceX (XNApp x xs)
| HcNApp2  : forall x xs,
    Exists hasChoiceX xs
    -> hasChoiceX (XNApp x xs)
| HcFix    : forall t1 t2 x,
    hasChoiceX x
    -> hasChoiceX (XFix t1 t2 x)
| HcCon    : forall dc xs,
    Exists hasChoiceX xs
    -> hasChoiceX (XCon dc xs)
| HcMatch1  : forall x aa,
    hasChoiceX x
    -> hasChoiceX (XMatch x aa)
| HcMatch2  : forall x aa,
    Exists hasChoiceA aa
    -> hasChoiceX (XMatch x aa)
| HcChoice  : forall t pc xs,
    hasChoiceX (XChoice t pc xs)

with hasChoiceA : alt -> Prop :=
     | HcAlt : forall dc ts x,
         hasChoiceX x
         -> hasChoiceA (AAlt dc ts x).

Hint Constructors hasChoiceX.
Hint Constructors hasChoiceA.

Record method : Type :=
  mkMethod {
      arity : nat;
      dom : list ty;
      body : exp;
      cod : ty
    }.

Inductive adt : Type :=
| IADT : ty -> list method -> list ty -> adt.
Hint Constructors adt.

(* Programs *)
Inductive prog : Type :=
| PLET : adt -> prog -> prog
| PEXP : exp -> prog.
Hint Constructors prog.

Inductive hasChoiceP : prog -> Prop :=
| HcLet : forall ad p',
    hasChoiceP p'
    -> hasChoiceP (PLET ad p')
| HcExp : forall x,
    hasChoiceX x
    -> hasChoiceP (PEXP x).
Hint Constructors hasChoiceP.

(* Weak normal forms cannot be reduced further by
   call-by-value evaluation. *)
Inductive wnfX : exp -> Prop :=
 | Wnf_XVar
   : forall i
   , wnfX (XVar i)

 | Wnf_XTup
   : forall xs,
     Forall wnfX xs
     -> wnfX (XTup xs)

 | Wnf_XNFun
   : forall ts x,
     wnfX (XNFun ts x)

 | Wnf_XFix
   : forall t1 t2 x,
     wnfX (XFix t1 t2 x)

 | Wnf_XCon
   : forall dc xs,
     Forall wnfX xs
     -> wnfX (XCon dc xs).
Hint Constructors wnfX.

(* A well formed expression is closed under the given environments *)
Inductive wfX : kienv -> tyenv -> exp -> Prop :=
| WfX_XVar : forall ke te i t,
    get i te = Some t -> wfX ke te (XVar i)
| WfX_XApp : forall ke te x1 x2,
    wfX ke te x1 -> wfX ke te x2
    -> wfX ke te (XApp x1 x2)
| WfX_XTup : forall ke te xs,
    Forall (wfX ke te) xs
    -> wfX ke te (XTup xs)
| WfX_XProj : forall ke te n x,
    wfX ke te x
    -> wfX ke te (XProj n x)
| WfX_XNFun : forall ke te ts x,
    Forall (wfT ke) ts
    -> wfX ke (te >< ts) x
    -> wfX ke te (XNFun ts x)
| WfX_XNApp : forall ke te x xs,
    wfX ke te x
    -> Forall (wfX ke te) xs
    -> wfX ke te (XNApp x xs)
| WfX_XFix : forall ke te t1 t2 x,
    wfT ke t1
    -> wfT ke t2
    -> wfX ke (te :> (TFun t1 t2) :> t1) x
    -> wfX ke te (XFix t1 t2 x)
| WfX_XCon : forall ke te dc xs,
    Forall (wfX ke te) xs
    -> wfX ke te (XCon dc xs)
| WfX_XMatch : forall ke te x aa,
    wfX ke te x
    -> Forall (wfA ke te) aa
    -> wfX ke te (XMatch x aa)
| WfX_XChoice : forall ke te t pc xs,
    wfT ke t
    -> Forall (wfX ke te) xs
    -> wfX ke te (XChoice t pc xs)

with wfA : kienv -> tyenv -> alt -> Prop :=
     | WfA_AAlt : forall ke te dc ds ts x tsArgs tRes,
         getDataDef dc ds = Some (DefData dc tsArgs tRes)
         -> wfX ke (te >< tsArgs) x
         -> wfA ke te (AAlt dc ts x).

Hint Constructors wfA.
Hint Constructors wfX.

(* Closed expressions are well formed under empty environments *)
Definition closedX (xx: exp) : Prop
 := wfX nil nil xx.
Hint Unfold closedX.

(* Values are closed expressions that cannot be reduced further. *)
Inductive value : exp -> Prop :=
 | Value
   :  forall xx
   ,  wnfX xx -> closedX xx
   -> value xx.
Hint Constructors value.

(********************************************************************)
(* Lift type indices in expressions. *)
(* Note: only ever need lift of size 1 at a time *)
Fixpoint liftTX (d: nat) (xx: exp) : exp :=
  match xx with
  | XVar _     => xx

  | XApp x1 x2
    => XApp (liftTX d x1) (liftTX d x2)

  | XTup xs
    => XTup (map (liftTX d) xs)

  | XProj n x
    => XProj n (liftTX d x)

  | XNFun ts x
    => XNFun (map (liftTT d) ts) (liftTX d x)

  | XNApp x xs
    => XNApp (liftTX d x) (map (liftTX d) xs)

  | XFix t1 t2 x
    => XFix (liftTT d t1) (liftTT d t2) (liftTX d x)

  | XCon dc xs
    => XCon dc (map (liftTX d) xs)

  | XMatch x aa
    => XMatch (liftTX d x) (map (liftTA d) aa)

  | XChoice t pc xs
    => XChoice (liftTT d t) pc (map (liftTX d) xs)
  end

with liftTA (d: nat) (a : alt) : alt :=
       match a with
       | AAlt dc ts x => AAlt dc (map (liftTT d) ts) (liftTX d x)
       end.

(* Lift value indices in expressions. *)
Fixpoint liftXX (n: nat) (d: nat) (xx: exp) : exp :=
  match xx with
  | XVar ix
    => if le_gt_dec d ix
      then XVar (n + ix)
      else xx

  | XApp x1 x2
    => XApp (liftXX n d x1) (liftXX n d x2)

  | XTup xs
    => XTup (map (liftXX n d) xs)

  | XProj n' x
    => XProj n' (liftXX n d x)

  | XNFun ts x
    => XNFun ts (liftXX n (d + length ts) x)

  | XNApp x xs
    => XNApp (liftXX n d x) (map (liftXX n d) xs)

  (* Increase value depth when moving across value abstractions. *)
  | XFix t1 t2 x
    => XFix t1 t2 (liftXX n (S (S d)) x)

  | XCon dc xs
    => XCon dc (map (liftXX n d) xs)

  | XMatch x aa
    => XMatch (liftXX n d x) (map (liftXA n d) aa)

  | XChoice t pc xs
    => XChoice t pc (map (liftXX n d) xs)
  end

with liftXA (n: nat) (d: nat) (a: alt) : alt :=
       match a with
       | AAlt dc ts x => AAlt dc ts (liftXX n (d + length ts) x)
       end.

(********************************************************************)
(* Substitution of types in expressions. *)
Fixpoint substTX (d: nat) (u: ty) (xx: exp) : exp :=
  match xx with
  | XVar _     => xx

  | XApp x1 x2
    => XApp (substTX d u x1) (substTX d u x2)

  | XTup xs
    => XTup (map (substTX d u) xs)

  | XProj n x
    => XProj n (substTX d u x)

  | XNFun ts x
    => XNFun (map (substTT d u) ts) (substTX d u x)

  | XNApp x xs
    => XNApp (substTX d u x) (map (substTX d u) xs)

  | XFix t1 t2 x
    => XFix (substTT d u t1) (substTT d u t2) (substTX d u x)

  | XCon dc xs
    => XCon dc (map (substTX d u) xs)

  | XMatch x aa
    => XMatch (substTX d u x) (map (substTA d u) aa)

  | XChoice t pc xs
    => XChoice (substTT d u t) pc (map (substTX d u) xs)
  end

with substTA (d: nat) (u: ty) (a: alt) : alt :=
       match a with
       | AAlt dc ts x => AAlt dc (map (substTT d u) ts) (substTX d u x)
       end.

(* Substitution of expressions in expressions. *)
Fixpoint substXX (d: nat) (u: exp) (xx: exp) : exp :=
  match xx with
  | XVar ix
    => match nat_compare ix d with
      | Eq => u
      | Gt => XVar (ix - 1)
      | _  => XVar  ix
      end
  | XApp x1 x2
    => XApp (substXX d u x1) (substXX d u x2)

  | XTup xs
    => XTup (map (substXX d u) xs)

  | XProj n x
    => XProj n (substXX d u x)

  | XNFun ts x
    => XNFun ts (substXX (d + length ts) (liftXX (length ts) 0 u) x)

  | XNApp x xs
    => XNApp (substXX d u x) (map (substXX d u) xs)

  (* Lift free value variables in the expression to be substituted
     when we move across value abstractions. *)
  | XFix t1 t2 x
    => XFix t1 t2 (substXX (S (S d)) (liftXX 2 0 u) x)

  | XCon dc xs
    => XCon dc (map (substXX d u) xs)

  | XMatch x aa
    => XMatch (substXX d u x) (map (substXA d u) aa)

  | XChoice t pc xs
    => XChoice t pc (map (substXX d u) xs)
  end

with substXA (d: nat) (u: exp) (a: alt) : alt :=
       match a with
       | AAlt dc ts x => AAlt dc ts (substXX (d + length ts) (liftXX (length ts) 0 u) x)
       end.

Fixpoint substXXs (d: nat) (us: list exp) (xx: exp) :=
 match us with
 | nil      => xx
 | u :: us' => substXXs d us'
                 (substXX d (liftXX (List.length us') 0 u)
                            xx)
 end.

(* The data constructor of an alternative is unchanged
   by lifting. *)
Lemma dcOfAlt_liftXA
 : forall n d a
 , dcOfAlt (liftXA n d a) = dcOfAlt a.
Proof.
 intros. destruct a. auto.
Qed.
Lemma dcOfAlt_liftTA
 : forall d a
 , dcOfAlt (liftTA d a) = dcOfAlt a.
Proof.
 intros. destruct a. auto.
Qed.
Lemma dcOfAlt_substXA
  : forall d u a,
    dcOfAlt (substXA d u a) = dcOfAlt a.
Proof.
  intros. destruct a. auto.
Qed.
Lemma dcOfAlt_substTA
  : forall d t a,
    dcOfAlt (substTA d t a) = dcOfAlt a.
Proof.
  intros. destruct a. auto.
Qed.

(* When we lift an expression by zero places,
   then the expression is unchanged. *)
Lemma liftXX_zero
  : forall d x,
    liftXX 0 d x = x.
Proof.
  intros. gen d.
  induction x using exp_mutind with
      (PA := fun a => forall d
               ,  liftXA 0 d a = a);
    rip; simpl;
      try (solve [f_equal; rewritess; burn]).

  Case "XVar".
  lift_cases; burn.

  Case "XTup".
  nforall.
  rewrite (map_ext_in (liftXX 0 d) id); auto.
  rewrite map_id; auto.

  Case "XNApp".
  nforall.
  rewrite (map_ext_in (liftXX 0 d) id); auto.
  rewrite map_id; auto. rewrite IHx; auto.

  Case "XCon".
  nforall.
  rewrite (map_ext_in (liftXX 0 d) id); auto.
  rewrite map_id; auto.

  Case "XMatch".
  nforall.
  rewrite (map_ext_in (liftXA 0 d) id); auto.
  rewrite map_id. rewrite IHx; auto.

  Case "XChoice".
  nforall.
  rewrite (map_ext_in (liftXX 0 d) id); auto.
  rewrite map_id; auto.
Qed.

(* Commutivity of expression lifting. *)
Lemma liftXX_comm
 : forall n m x d
 , liftXX n d (liftXX m d x)
 = liftXX m d (liftXX n d x).
Proof.
 intros. gen d.
 induction x using exp_mutind with
  (PA := fun a => forall d
      ,  liftXA n d (liftXA m d a)
      =  liftXA m d (liftXA n d a));
   rip; simpl;
   try (solve [f_equal; rewritess; burn]).

 Case "XVar".
 repeat (simpl; lift_cases; intros);
   try solve [f_equal; omega].

 Case "XTup".
 f_equal.
 repeat (rewrite map_map).
 rewrite Forall_forall in *.
 rewrite (map_ext_in
            (fun x0 => liftXX n d (liftXX m d x0))
            (fun x0 => liftXX m d (liftXX n d x0))); burn.

 Case "XNApp".
 f_equal. apply IHx; auto.
 repeat (rewrite map_map).
 rewrite Forall_forall in *.
 rewrite (map_ext_in
            (fun x0 => liftXX n d (liftXX m d x0))
            (fun x0 => liftXX m d (liftXX n d x0))); burn.

 Case "XCon".
 f_equal.
 repeat (rewrite map_map).
 rewrite Forall_forall in *.
 rewrite (map_ext_in
            (fun x0 => liftXX n d (liftXX m d x0))
            (fun x0 => liftXX m d (liftXX n d x0))); burn.

 Case "XMatch".
 f_equal. burn.
 repeat (rewrite map_map).
 rewrite Forall_forall in *.
 rewrite (map_ext_in
            (fun a1 => liftXA n d (liftXA m d a1))
            (fun a1 => liftXA m d (liftXA n d a1))); burn.

 Case "XChoice".
 f_equal.
 repeat (rewrite map_map).
 rewrite Forall_forall in *.
 rewrite (map_ext_in
            (fun x0 => liftXX n d (liftXX m d x0))
            (fun x0 => liftXX m d (liftXX n d x0))); burn.
Qed.

Ltac burn_liftXX_succ :=
  match goal with
  | [ H : Forall _ _ |- map _ _ = map _ _ ] =>
    repeat (rewrite map_map);
    rewrite Forall_forall in *
  end.

(* When consecutively lifting an expression, we can lift by one
   more place in the first lifting and one less in the second. *)
Lemma liftXX_succ
 : forall n m d x
 , liftXX (S n) d (liftXX m     d x)
 = liftXX n     d (liftXX (S m) d x).
Proof.
  intros. gen d.
  induction x using exp_mutind with
      (PA := fun a => forall d
               ,  liftXA (S n) d (liftXA  m    d a)
                  =  liftXA n     d (liftXA (S m) d a));
    rip; simpl;
      try (solve [f_equal; rewritess; burn]).

  Case "XVar".
  repeat (simple; lift_cases; intros);
    try (solve [f_equal; omega]).

  Case "XTup".
  f_equal.
  burn_liftXX_succ.
  rewrite (map_ext_in
             (fun x0 => liftXX (S n) d (liftXX m d x0))
             (fun x0 => liftXX n d (liftXX (S m) d x0))); burn.

  Case "XNApp".
  f_equal. apply IHx; auto.
  burn_liftXX_succ.
  rewrite (map_ext_in
             (fun x0 => liftXX (S n) d (liftXX m d x0))
             (fun x0 => liftXX n d (liftXX (S m) d x0))); burn.

  Case "XCon".
  f_equal.
  burn_liftXX_succ.
  rewrite (map_ext_in
             (fun x0 => liftXX (S n) d (liftXX m d x0))
             (fun x0 => liftXX n d (liftXX (S m) d x0))); burn.

  Case "XMatch".
  f_equal. eauto.
  burn_liftXX_succ.
  rewrite (map_ext_in
             (fun x1 => liftXA (S n) d (liftXA m d x1))
             (fun x1 => liftXA n d (liftXA (S m) d x1))); burn.

  Case "XChoice".
  f_equal.
  burn_liftXX_succ.
  rewrite (map_ext_in
             (fun x0 => liftXX (S n) d (liftXX m d x0))
             (fun x0 => liftXX n d (liftXX (S m) d x0))); burn.
Qed.

(* We can collapse two consecutive lifting expressions by lifting
   just once by the sum of the places, provided the lifting
   occurs at depth zero. *)
Lemma liftXX_plus
 : forall n m x
 , liftXX n 0 (liftXX m 0 x) = liftXX (n + m) 0 x.
Proof.
 intros. gen n.
 induction m.
  intros. rewrite liftXX_zero. nnat. burn.
  intros.
   rrwrite (n + S m = S n + m).
   rewrite liftXX_comm.
   rewrite <- IHm.
   rewrite liftXX_comm.
   rewrite liftXX_succ.
   auto.
Qed.

(* -------------------------Existential----------------------------------- *)
Definition substTM (d : nat) (u : ty) (m : method) : method :=
  match m with
  | mkMethod arity dom body cod =>
    mkMethod arity
             (map (substTT d u) dom)
             (substTX d u body)
             (substTT d u cod)
  end.

Definition substXM (d : nat) (u : exp) (m : method) : method :=
  match m with
  | mkMethod arity dom body cod =>
    mkMethod arity dom (substXX d u body) cod
  end.

Definition substTADT (d : nat) (u : ty) (ad : adt) : adt :=
  match ad with
  | IADT r ms ss => IADT (substTT d u r) (map (substTM d u) ms) (map (substTT d u) ss)
  end.

Fixpoint substTP (d : nat) (u : ty) (p : prog) : prog :=
  match p with
  | PLET ad p' => PLET (substTADT d u ad) (substTP (S d) (liftTT 0 u) p')
  | PEXP x     => PEXP (substTX d u x)
  end.

(* Substitution of expressions in ADTs. *)
Definition substXADT (d : nat) (u : exp) (ad : adt) : adt :=
  match ad with
  | IADT r ms ss => IADT r (map (substXM d u) ms) ss
  end.

(* Substitution of expressions in programs. *)
Fixpoint substXP (d : nat) (u : exp) (p : prog) : prog :=
  match p with
  | PLET ((IADT r ms ss) as ad) p'
    => PLET (substXADT d u ad)
           (substXP (d + length ms)
                    (liftXX (length ms) 0 (liftTX 0 u))
                    p')
  | PEXP x
    => PEXP (substXX d u x)
  end.

Fixpoint substXXsP (d : nat) (us : list exp) (p : prog) :=
  match us with
  | nil => p
  | u :: us' => substXXsP d us'
                         (substXP d (liftXX (List.length us') 0 u)
                                  p)
  end.

(* Weak normal forms cannot be reduced further by
   call-by-value evaluation. *)
Inductive wnfP : prog -> Prop :=
 | Wnf_PExp
   : forall x,
     wnfX x
     -> wnfP (PEXP x).
Hint Constructors wnfP.

Definition wfMethod (ke : kienv) (te : tyenv) (m : method) : Prop :=
  match m with
  | mkMethod arity dom (XNFun ts x as body) cod =>
    wfX ke te body
    /\ length ts = arity + (length dom)
    /\ wfT ke cod
  | _ => False
  end.

Definition wfADT (ke : kienv) (te : tyenv) (ad : adt) : Prop :=
  match ad with
  | IADT r ms ss => wfT ke r
                   /\ Forall (wfMethod ke te) ms
                   /\ Forall (wfT ke) ss
  end.
Hint Unfold wfADT.

Fixpoint hackyBuildStrippedTypes (ts : list ty) :=
  match ts with
  | (TExists t) :: ts' => t :: (hackyBuildStrippedTypes ts')
  | _ :: ts' => hackyBuildStrippedTypes ts'
  | nil => nil
  end.

Fixpoint wfP (ke: kienv) (te: tyenv) (p: prog) : Prop :=
  match p with
  | PLET ad p' =>
    match ad with
    | IADT r ms ss =>
      wfADT ke te ad /\ wfP (ke :> KStar) (te >< (hackyBuildStrippedTypes ss)) p'
    end
  | PEXP x => wfX ke te x
  end.
Hint Unfold wfP.

(* Closed programs are well formed under empty environments *)
Definition closedP (p : prog) : Prop
 := wfP nil nil p.
Hint Unfold closedP.

(* ValuePs are closed programs that cannot be reduced further. *)
Inductive valueP : prog -> Prop :=
 | ValueP
   : forall p,
     wnfP p -> closedP p
     -> valueP p.
Hint Constructors valueP.


(* Checks syntax of Hints commands *)
(* Old-style syntax *)
Hint Resolve eq_refl eq_sym.
Hint Resolve eq_refl eq_sym: foo.
Hint Immediate eq_refl eq_sym.
Hint Immediate eq_refl eq_sym: foo.
Hint Unfold fst eq_sym.
Hint Unfold fst eq_sym: foo.

(* Checks that qualified names are accepted *)

(* New-style syntax *)
Hint Resolve eq_refl: core arith.
Hint Immediate eq_trans.
Hint Unfold eq_sym: core.
Hint Constructors eq: foo bar.
Hint Extern 3 (_ = _) => apply eq_refl: foo bar.

(* Extended new syntax with patterns *)
Hint Resolve eq_refl | 4 (_ = _) : baz.
Hint Resolve eq_sym eq_trans : baz.
Hint Extern 3 (_ = _) => apply eq_sym : baz.

Parameter pred : nat -> Prop.
Parameter pred0 : pred 0.
Parameter f : nat -> nat.
Parameter predf : forall n, pred n -> pred (f n).

(* No conversion on let-bound variables and constants in pred (the default) *)
Hint Resolve pred0 | 1 (pred _) : pred.
Hint Resolve predf | 0 : pred.

(* Allow full conversion on let-bound variables and constants *)
Create HintDb predconv discriminated.
Hint Resolve pred0 | 1 (pred _) : predconv.
Hint Resolve predf | 0 : predconv.

Goal exists n, pred n.
  eexists.
  Set Typeclasses Filtered Unification.
  Set Typeclasses Debug Verbosity 2.
  (* predf is not tried as it doesn't match the goal *)
  typeclasses eauto with pred.
Qed.

Parameter predconv : forall n, pred n -> pred (0 + S n).

(* The inferred pattern contains 0 + ?n, syntactic match will fail to see convertible
 terms *)
Hint Resolve pred0 : pred2.
Hint Resolve predconv : pred2.

(** In this database we allow predconv to apply to pred (S _) goals, more generally
  than the inferred pattern (pred (0 + S _)). *)
Create HintDb pred2conv discriminated.
Hint Resolve pred0 : pred2conv.
Hint Resolve predconv | 1 (pred (S _)) : pred2conv.

Goal pred 3.
  Fail typeclasses eauto with pred2.
  typeclasses eauto with pred2conv.
Abort.

Set Typeclasses Filtered Unification.
Set Typeclasses Debug Verbosity 2.
Hint Resolve predconv | 1 (pred _) : pred.
Hint Resolve predconv | 1 (pred (S _)) : predconv.
Test Typeclasses Limit Intros.
Goal pred 3.
  (* predf is not tried as it doesn't match the goal *)
  (* predconv is tried but fails as the transparent state doesn't allow
     unfolding + *)
  Fail typeclasses eauto with pred.
  (* Here predconv succeeds as it matches (pred (S _)) and then
     full unification is allowed *)
  typeclasses eauto with predconv.
Qed.

(** The other way around: goal contains redexes instead of instances *)
Goal exists n, pred (0 + n).
  eexists.
  (* pred0 (pred _) matches the goal *)
  typeclasses eauto with predconv.
Qed.

(* Checks that local names are accepted *)
Section A.
  Remark Refl : forall (A : Set) (x : A), x = x.
  Proof. exact @eq_refl. Defined.
  Definition Sym := eq_sym.
  Let Trans := eq_trans.

  Hint Resolve Refl: foo.
  Hint Resolve Sym: bar.
  Hint Resolve Trans: foo2.

  Hint Immediate Refl.
  Hint Immediate Sym.
  Hint Immediate Trans.

  Hint Unfold Refl.
  Hint Unfold Sym.
  Hint Unfold Trans.

  Hint Resolve Sym Trans Refl.
  Hint Immediate Sym Trans Refl.
  Hint Unfold Sym Trans Refl.

End A.

Axiom a : forall n, n=0 <-> n<=0.

Hint Resolve -> a.
Goal forall n, n=0 -> n<=0.
auto.
Qed.

(* This example comes from Chlipala's ltamer *)
(* It used to fail from r12902 to r13112 since type_of started to call *)
(* e_cumul (instead of conv_leq) which was not able to unify "?id" and *)
(* "(fun x => x) ?id" *)

Notation "e :? pf" := (eq_rect _ (fun X : Set => X) e _ pf)
  (no associativity, at level 90).

Axiom cast_coalesce :
  forall (T1 T2 T3 : Set) (e : T1) (pf1 : T1 = T2) (pf2 : T2 = T3),
  ((e :? pf1) :? pf2) = (e :? trans_eq pf1 pf2).

Hint Rewrite cast_coalesce : ltamer.

Require Import Program.
Module HintCut.
Class A (f : nat -> nat) := a : True.
Class B (f : nat -> nat) := b : True.
Class C (f : nat -> nat) := c : True.
Class D (f : nat -> nat) := d : True.
Class E (f : nat -> nat) := e : True.

Instance a_is_b f : A f -> B f.
Proof. easy. Qed.
Instance b_is_c f : B f -> C f.
Proof. easy. Qed.
Instance c_is_d f : C f -> D f.
Proof. easy. Qed.
Instance d_is_e f : D f -> E f.
Proof. easy. Qed.

Instance a_compose f g : A f -> A g -> A (compose f g).
Proof. easy. Qed.
Instance b_compose f g : B f -> B g -> B (compose f g).
Proof. easy. Qed.
Instance c_compose f g : C f -> C g -> C (compose f g).
Proof. easy. Qed.
Instance d_compose f g : D f -> D g -> D (compose f g).
Proof. easy. Qed.
Instance e_compose f g : E f -> E g -> E (compose f g).
Proof. easy. Qed.

Instance a_id : A id.
Proof. easy. Qed.

Instance foo f :
  E (id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘
     id ∘ id ∘ id ∘ id ∘ id ∘ f ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id).
Proof.
Hint Cut [_* (a_is_b | b_is_c | c_is_d | d_is_e)
                 (a_compose | b_compose | c_compose | d_compose | e_compose)] : typeclass_instances.

  Timeout 1 Fail apply _. (* 0.06s *)
Abort.
End HintCut.

(* Check that auto-like tactics do not prefer "eq_refl" over more complex solutions, *)
(* e.g. those tactics when considering a goal with existential varibles *)
(* like "m = ?n" won't pick "plus_n_O" hint over "eq_refl" hint. *)
(* See this Coq club post for more detail: *)
(* https://sympa.inria.fr/sympa/arc/coq-club/2017-12/msg00103.html *)

Goal forall (m : nat), exists n, m = n /\ m = n.
  intros m; eexists; split; [trivial | reflexivity].
Qed.

Section HintTransparent.

  Definition fn (x : nat) := S x.

  Create HintDb trans.

  Hint Resolve eq_refl | (_ = _) : trans.

  (* No reduction *)
  Hint Variables Opaque : trans.  Hint Constants Opaque : trans.

  Goal forall x : nat, fn x = S x.
  Proof.
    intros.
    Fail typeclasses eauto with trans.
    unfold fn.
    typeclasses eauto with trans.
  Qed.

  (** Now allow unfolding fn *)
  Hint Constants Transparent : trans.

  Goal forall x : nat, fn x = S x.
  Proof.
    intros.
    typeclasses eauto with trans.
  Qed.

End HintTransparent.


Require Import Fsub.
Require Import Dsub.

Set Implicit Arguments.
Require Import LibLN.
Implicit Types x : var.
Implicit Types X : var.

Fixpoint emb_t (T: Fsub.typ): Dsub.typ :=
  match T with
    | Fsub.typ_top => typ_top
    | Fsub.typ_bvar i => typ_sel (trm_bvar i)
    | Fsub.typ_fvar x => typ_sel (trm_fvar x)
    | Fsub.typ_arrow T U => typ_all (emb_t T) (emb_t U)
    | Fsub.typ_all T U => typ_all (typ_mem false (emb_t T)) (emb_t U)
  end.

Fixpoint emb_e (e: Fsub.trm): Dsub.trm :=
  match e with
    | Fsub.trm_bvar i => trm_bvar i
    | Fsub.trm_fvar x => trm_fvar x
    | Fsub.trm_abs T e => trm_abs (emb_t T) (emb_e e)
    | Fsub.trm_tabs T e => trm_abs (typ_mem false (emb_t T)) (emb_e e)
    | Fsub.trm_app e1 e2 => trm_app (emb_e e1) (emb_e e2)
    | Fsub.trm_tapp e1 U => trm_app (emb_e e1) (trm_mem (emb_t U))
  end.

Definition emb_tb (b: bind): Dsub.typ :=
  match b with
    | bind_sub T => typ_mem false (emb_t T)
    | bind_typ T => emb_t T
  end.

Definition emb_env (E: Fsub.env): Dsub.env := map emb_tb E.

Lemma binds_preserved: forall X b E,
  binds X b E ->
  binds X (emb_tb b) (emb_env E).
Proof.
  intros. apply* binds_map.
Qed.

Lemma binds_sub_preserved: forall X U E,
  binds X (bind_sub U) E ->
  binds X (typ_mem false (emb_t U)) (emb_env E).
Proof.
  intros. apply binds_preserved in H. simpl in H. apply H.
Qed.

Lemma binds_typ_preserved: forall X U E,
  binds X (bind_typ U) E ->
  binds X (emb_t U) (emb_env E).
Proof.
  intros. apply binds_preserved in H. simpl in H. apply H.
Qed.

Lemma open_var_emb_commute: forall T y,
  (emb_t (T open_tt_var y))=(emb_t T open_t_var y).
Proof.
  intros. unfold Fsub.open_tt. unfold Dsub.open_t.
  remember 0 as n. clear Heqn. generalize dependent n.
  induction T; intros; simpl;
  try rewrite IHT1; try rewrite IHT2;
  eauto.
  - simpl. case_if; eauto.
Qed.

Lemma wft_preserved: forall E T,
  ok (emb_env E) ->
  Fsub.wft E T ->
  Dsub.wft (emb_env E) (emb_t T).
Proof.
  introv Ok H. induction H; eauto.
  - simpl. apply wft_sel. right. eexists. reflexivity.
    eapply wfe_var. eapply binds_sub_preserved; eauto.
  - simpl. apply wft_all with (L:=dom (emb_env E)); eauto; intros.
    rewrite open_t_var_type. apply wft_weaken_right.
    eapply IHwft2; eauto. apply ok_push; eauto. apply* wft_type.
  - simpl. apply wft_all with (L:=L \u dom (emb_env E)); eauto. intros y Fry.
    assert (y \notin L) as Fr by auto. specialize (H1 y Fr).
    assert (ok (emb_env (E & y ~ bind_sub T1))) as A. {
      unfold emb_env in *. rewrite map_concat. rewrite map_single.
      apply ok_push. apply Ok. auto*.
    }
    specialize (H1 A). unfold emb_env in *.
    rewrite map_concat in H1. rewrite map_single in H1. simpl in H1.
    rewrite open_var_emb_commute in H1. apply H1.
Qed.

Lemma okt_preserved: forall E,
  Fsub.okt E ->
  Dsub.okt (emb_env E).
Proof.
  intros. induction E using env_ind.
  - unfold emb_env. rewrite map_empty. auto.
  - unfold emb_env. rewrite map_concat. rewrite map_single.
    destruct (Fsub.okt_push_inv H) as [T [? | ?]]; subst.
    + destruct (Fsub.okt_push_sub_inv H) as [Ok [Hwf Fr]].
      apply okt_push; auto.
      specialize (IHE Ok).
      assert (ok (emb_env E)) as Ok' by solve [apply* ok_from_okt].
      lets Hwf': (wft_preserved Ok' Hwf).
      unfold emb_env in Hwf'. simpl.
      apply wft_mem. apply Hwf'.
    + destruct (Fsub.okt_push_typ_inv H) as [Ok [Hwf Fr]].
      apply okt_push; auto.
      specialize (IHE Ok).
      assert (ok (emb_env E)) as Ok' by solve [apply* ok_from_okt].
      lets Hwf': (wft_preserved Ok' Hwf).
      unfold emb_env in Hwf'. simpl.
      apply Hwf'.
Qed.

Theorem preservation_of_subtyping: forall E S T,
  Fsub.sub E S T ->
  Dsub.sub (emb_env E) (emb_t S) (emb_t T).
Proof.
  intros. induction H.
  - apply* sub_top. apply* okt_preserved. apply* wft_preserved.
    apply* ok_from_okt. apply* okt_preserved.
  - simpl. apply* sub_refl_sel. apply* okt_preserved.
    apply wft_preserved in H0. simpl in H0. apply H0.
    apply ok_from_okt. apply* okt_preserved.
  - simpl. apply* sub_sel1. eapply has_sub. apply has_var.
    apply* okt_preserved. eapply binds_sub_preserved; eauto.
    apply* sub_mem_false.
  - simpl. apply sub_all with (L:=dom (emb_env E)). auto. intros y Fr.
    rewrite open_t_var_type. rewrite open_t_var_type.
    rewrite <- (@concat_empty_r typ (y ~ emb_t T1)). rewrite concat_assoc.
    eapply sub_weakening1. assumption. rewrite concat_empty_r.
    apply okt_push. apply* okt_preserved.
    apply sub_regular in IHsub1. auto*. auto.
    apply* wft_type. apply* wft_type.
  - simpl. apply sub_all with (L:=L \u dom (emb_env E)); eauto.
    apply* sub_mem_false. intros y Fry. assert (y \notin L) as Fr by auto.
    specialize (H1 y Fr). unfold emb_env in H1. simpl in H1.
    rewrite map_concat in H1. rewrite map_single in H1. simpl in H1.
    repeat rewrite open_var_emb_commute in H1. apply H1.
Qed.

Fixpoint subst_tt (z : var) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_sel (trm_fvar x) => If x = z then U else typ_sel (trm_fvar x)
  | typ_sel e            => typ_sel (subst_te z U e)
  | typ_top         => typ_top
  | typ_mem b T1    => typ_mem b (subst_tt z U T1)
  | typ_all T1 T2   => typ_all (subst_tt z U T1) (subst_tt z U T2)
  end
with subst_te (z : var) (U : typ) (e : trm) {struct e } : trm :=
  match e with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => trm_fvar x
  | trm_abs V e1  => trm_abs (subst_tt z U V) (subst_te z U e1)
  | trm_mem T1    => trm_mem (subst_tt z U T1)
  | trm_app e1 e2 => trm_app (subst_te z U e1) (subst_te z U e2)
  end.

Lemma subst_tt_emb_commute: forall X U T,
  type (emb_t U) ->
  emb_t (Fsub.subst_tt X U T) = subst_tt X (emb_t U) (emb_t T).
Proof.
  intros.
  induction T; intros; subst; simpl; eauto;
  try rewrite IHT1; try rewrite IHT2;
  eauto.
  - case_if; eauto.
Qed.

Lemma subst_tt_open_t_var_rec :
  (forall T X Y U, Y <> X -> type U -> forall k,
   open_t_rec k (trm_fvar Y) (subst_tt X U T) = subst_tt X U (open_t_rec k (trm_fvar Y) T))
  /\
  (forall e X Y U, Y <> X -> type U -> forall k,
   open_e_rec k (trm_fvar Y) (subst_te X U e) = subst_te X U (open_e_rec k (trm_fvar Y) e)).
Proof.
  apply typ_trm_mutind; intros; simpl; eauto;
  try rewrite* H; try rewrite* H0.
  - simpl. specialize (H X Y U H0 H1 k).
    destruct t; simpl in *; eauto; try solve [f_equal; auto].
    case_if; eauto. case_if; eauto. case_if; eauto.
    rewrite <- (proj1 open_rec_lc). reflexivity. auto.
  - case_if; eauto.
Qed.

Lemma subst_tt_open_t_var : forall X Y U T, Y <> X -> type U ->
  (subst_tt X U T) open_t_var Y = subst_tt X U (T open_t_var Y).
Proof.
  intros. unfold open_t. apply* (proj1 subst_tt_open_t_var_rec).
Qed.

Lemma subst_te_open_t_var : forall X Y U e, Y <> X -> type U ->
  (subst_te X U e) open_e_var Y = subst_te X U (e open_e_var Y).
Proof.
  intros. unfold open_e. apply* (proj2 subst_tt_open_t_var_rec).
Qed.

Lemma wf_subst_tt:
  (forall E T, wft E T -> ok E -> forall x U, wft E U -> wft E (subst_tt x U T))
  /\
  (forall E e, wfe E e -> ok E -> forall x U, wft E U -> wfe E (subst_te x U e)).
Proof.
  apply wf_mutind; intros; subst; eauto.
  - specialize (H H0 x U H1). destruct o as [Hv | Hx].
    + inversion Hv; subst.
      * simpl. simpl in H. apply wft_sel.
        left. apply value_abs. apply* wfe_term. auto.
      * simpl. simpl in H. apply wft_sel.
        left. apply value_mem. apply* wfe_term. auto.
    + destruct Hx as [z ?]. subst. simpl. case_if; auto*.
  - apply* wft_mem.
  - simpl. apply_fresh* wft_all as y.
    assert (y \notin L) as FrL by auto.
    assert (ok (E & y ~ T1)) as Ok'. {
      auto*.
    }
    specialize (H0 y FrL Ok' x U).
    assert (wft (E & y ~ T1) U) as HU'. {
      rewrite <- (@concat_empty_r typ (y ~ T1)). rewrite concat_assoc.
      apply wft_weaken.
      rewrite concat_empty_r. auto.
      rewrite concat_empty_r. auto.
    }
    specialize (H0 HU'). rewrite <- subst_tt_open_t_var in H0.
    rewrite <- (@concat_empty_r typ (y ~ subst_tt x U T1)).
    rewrite concat_assoc.
    eapply wft_narrow. rewrite concat_empty_r. eauto.
    rewrite concat_empty_r. auto*. auto. apply* wft_type.
  - simpl. auto*.
  - simpl. apply_fresh* wfe_abs as y.
    assert (y \notin L) as FrL by auto.
    assert (ok (E & y ~ V)) as Ok'. {
      auto*.
    }
    specialize (H0 y FrL Ok' x U).
    assert (wft (E & y ~ V) U) as HU'. {
      rewrite <- (@concat_empty_r typ (y ~ V)). rewrite concat_assoc.
      apply wft_weaken.
      rewrite concat_empty_r. auto.
      rewrite concat_empty_r. auto.
    }
    specialize (H0 HU'). rewrite <- subst_te_open_t_var in H0.
    rewrite <- (@concat_empty_r typ (y ~ subst_tt x U V)).
    rewrite concat_assoc.
    eapply (proj2 wf_narrow). eapply H0. rewrite concat_empty_r. eauto.
    rewrite concat_empty_r. auto*. auto. apply* wft_type.
  - simpl. auto*.
  - simpl. auto*.
Qed.

Lemma sub_subst_tt_admissible_rec:
  (forall E T,
     wft E T ->
     (forall x U,
        has E (trm_fvar x) (typ_mem true U) ->
        sub E (subst_tt x U T) T /\ sub E T (subst_tt x U T)))
  /\
  (forall E e,
     wfe E e -> value e ->
     (forall x U,
        has E (trm_fvar x) (typ_mem true U) ->
        sub E (typ_sel (subst_te x U e)) (typ_sel e) /\
        sub E (typ_sel e) (typ_sel (subst_te x U e)))).
Proof.
  apply wf_mutind; intros; subst; eauto.
  - destruct o as [Hv | Hx].
    + inversion Hv; subst; simpl; specialize (H Hv x U H0); apply H.
    + destruct Hx as [z ?]. subst. simpl. case_if.
      * split. apply* sub_sel2. apply* sub_sel1.
        apply* has_sub. apply* sub_mem_false. apply* sub_reflexivity.
        apply (proj2 sub_has_regular) in H0. inversion H0 as [? [? A]].
        inversion A; subst. assumption.
      * split; apply* sub_refl_sel.
  - simpl. specialize (H x U H0). destruct H as [IH1 IH2].
    destruct b.
    * split; apply* sub_mem_true.
    * split; apply* sub_mem_false.
  - simpl.
    assert (type U) as HU. {
      apply (proj2 sub_has_regular) in H1. inversion H1 as [? [? A]].
      inversion A; subst. apply* wft_type.
    }
    split.
    + apply_fresh* sub_all as y.
      apply* H.
      assert (y \notin L) as FrL by auto. specialize (H0 y FrL).
      assert (has (E & y ~ T1) (trm_fvar x) (typ_mem true U)) as Has'. {
        rewrite <- (@concat_empty_r typ (y ~ T1)). rewrite concat_assoc.
        apply* has_weakening1. rewrite concat_empty_r. auto*.
      }
      specialize (H0 x U Has').
      destruct H0 as [IH1 IH2].
      rewrite subst_tt_open_t_var. apply IH1. auto*. auto*.
    + apply_fresh* sub_all as y.
      apply* H.
      assert (y \notin L) as FrL by auto. specialize (H0 y FrL).
      assert (has (E & y ~ T1) (trm_fvar x) (typ_mem true U)) as Has'. {
        rewrite <- (@concat_empty_r typ (y ~ T1)). rewrite concat_assoc.
        apply* has_weakening1. rewrite concat_empty_r. auto*.
      }
      specialize (H0 x U Has').
      destruct H0 as [IH1 IH2].
      rewrite subst_tt_open_t_var.
      rewrite <- (@concat_empty_r typ (y ~ subst_tt x U T1)).
      rewrite concat_assoc.
      apply* sub_narrowing. eapply H; eauto. rewrite concat_empty_r. apply IH2.
      auto*. auto*.
  - inversion H.
  - specialize (H x U H2). destruct H as [IH1 IH2].
    simpl.
    assert (ok E) as Ok by auto*.
    assert (wft E U) as HwfU. {
      apply (proj2 sub_has_regular) in H2. destruct H2 as [? [? A]].
      inversion A; subst. assumption.
    }
    assert (wfe E (trm_abs V e)) as Hwfe by auto*.
    lets Hwfe': ((proj2 wf_subst_tt) E (trm_abs V e) Hwfe Ok x U HwfU).
    split; apply* sub_sel_abs.
  - specialize (H x U H1). destruct H as [IH1 IH2].
    simpl. split.
    + eapply sub_trans.
      eapply sub_sel1. eapply has_mem. auto*. auto*.
      eapply sub_trans. eapply IH1.
      apply* sub_sel2. apply* has_mem.
    + eapply sub_trans.
      eapply sub_sel1. eapply has_mem. auto*. auto*.
      eapply sub_trans. eapply IH2.
      apply* sub_sel2. apply* has_mem.
  - inversion H1.
Qed.

Lemma open_var_emb_ee_commute: forall e y,
  (emb_e (e open_ee_var y))=(emb_e e open_e_var y).
Proof.
  (*
  intros. unfold Fsub.open_ee. unfold Dsub.open_e.
  remember 0 as n. clear Heqn. generalize dependent n.
  induction e; intros; simpl; eauto.
  - case_if; eauto.
  *)
  admit.
Qed.

Lemma open_var_emb_te_commute: forall e y,
  (emb_e (e open_te_var y))=(emb_e e open_e_var y).
Proof.
  (*
  intros. unfold Fsub.open_ee. unfold Dsub.open_e.
  remember 0 as n. clear Heqn. generalize dependent n.
  induction e; intros; simpl; eauto.
  - case_if; eauto.
  *)
  admit.
Qed.

Lemma open_tt_emb_commute: forall T2 T,
  emb_t (open_tt T2 T) = open_t (emb_t T2) (trm_mem (emb_t T)).
Proof.
  admit.
Qed.

Lemma open_val_emb_commute: forall v2 e1,
  Fsub.value v2 ->
  (emb_e (open_ee e1 v2)) = (open_e (emb_e e1) (emb_e v2)).
Proof.
  admit.
Qed.

Lemma open_te_emb_commute: forall V2 e1,
  Fsub.type V2 ->
  emb_e (open_te e1 V2) = open_e (emb_e e1) (trm_mem (emb_t V2)).
Proof.
  admit.
Qed.

Theorem preservation_of_typing: forall E t T,
  Fsub.typing E t T ->
  Dsub.typing (emb_env E) (emb_e t) (emb_t T).
Proof.
  intros. induction H; simpl.
  - apply typing_var. apply* okt_preserved. apply* binds_typ_preserved.
  - apply_fresh* typing_abs as y. assert (y \notin L) as FrL by auto.
    specialize (H0 y FrL). unfold emb_env in *.
    rewrite map_concat in H0. rewrite map_single in H0. simpl in H0.
    rewrite open_var_emb_ee_commute in H0.
    rewrite open_t_var_type. apply H0.
    apply wft_type with (E:=(emb_env E)).
    specialize (H y FrL). apply Fsub.typing_regular in H.
    destruct H as [? [? A]].
    apply* wft_preserved. apply ok_from_okt. apply* okt_preserved.
    apply okt_push_typ_inv in H. auto*.
    rewrite <- (@concat_empty_r bind E). apply* wft_strengthen.
    rewrite concat_empty_r. eauto.
  - apply* typing_app. apply* wft_preserved.
    apply Fsub.typing_regular in H. destruct H as [? [? A]]. inversion A; subst.
    assumption.
  - apply_fresh* typing_abs as y. assert (y \notin L) as FrL by auto.
    specialize (H0 y FrL). unfold emb_env in *.
    rewrite map_concat in H0. rewrite map_single in H0. simpl in H0.
    rewrite open_var_emb_te_commute in H0. rewrite open_var_emb_commute in H0.
    apply H0.
  - apply* typing_appvar.
    eapply typing_sub. eapply typing_mem. auto*. apply* wft_preserved.
    apply sub_mem_false. apply* preservation_of_subtyping.
    apply has_mem. auto*. apply* wft_preserved.
    rewrite open_tt_emb_commute. auto. admit.
  - eapply typing_sub. eapply IHtyping. apply* preservation_of_subtyping.
Grab Existential Variables.
apply true.
Qed.

Lemma term_preserved: forall e,
  Fsub.term e ->
  Dsub.term (emb_e e).
Proof.
  admit.
Qed.

Lemma type_preserved: forall T,
  Fsub.type T ->
  Dsub.type (emb_t T).
Proof.
  admit.
Qed.

Lemma value_preserved: forall e,
  Fsub.value e ->
  Dsub.value (emb_e e).
Proof.
  admit.
Qed.

Theorem red_preserved: forall e e',
  Fsub.red e e' ->
  Dsub.red (emb_e e) (emb_e e').
Proof.
  intros. induction H; simpl.
  - apply* red_app_1. apply* term_preserved.
  - apply* red_app_2. apply* value_preserved.
  - apply* red_app_1. apply* term_mem. apply* type_preserved.
  - rewrite* open_val_emb_commute. apply* red_abs.
    assert (trm_abs (emb_t V) (emb_e e1)=emb_e (Fsub.trm_abs V e1)) as A
        by solve [simpl; auto].
    rewrite A. apply* term_preserved. apply* value_preserved.
  - rewrite* open_te_emb_commute. apply* red_abs.
    inversion H; subst. apply_fresh* term_abs as y.
    apply* type_mem. apply* type_preserved.
    rewrite <- open_var_emb_te_commute. apply* term_preserved.
    apply* value_mem. apply* term_mem. apply* type_preserved.
Qed.