Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export DoubleUnfolding.

Module Nominal.

Inductive typ : Set :=
| typ_top   : typ
| typ_nat   : typ
| typ_bvar  : nat -> typ
| typ_fvar  : var -> typ
| typ_mu :    typ -> typ
| typ_arrow : typ -> typ -> typ
| typ_rcd : var -> typ -> typ
.

Coercion typ_bvar : nat >-> typ.
Coercion typ_fvar : atom >-> typ.

Fixpoint open_tt_rec (K : nat) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_nat         => typ_nat
  | typ_top         => typ_top
  | typ_bvar J      => if K === J then U else (typ_bvar J)
  | typ_fvar X      => typ_fvar X
  | typ_arrow T1 T2 => typ_arrow (open_tt_rec K U T1) (open_tt_rec K U T2)
  | typ_mu T        => typ_mu (open_tt_rec (S K) U T)
  | typ_rcd l T => typ_rcd l (open_tt_rec K U T)
  end.

(* T type U name *)
Definition open_tt T U := open_tt_rec 0 U T.

(** Types as locally closed pre-types *)

Inductive type : typ -> Prop :=
  | type_top :
      type typ_top
  | type_nat :
      type typ_nat
  | type_var : forall X,
      type (typ_fvar X)
  | type_arrow : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_arrow T1 T2)
  | type_rcd : forall l T,
      type T ->
      type (typ_rcd l T)
  | type_mu : forall L T,
      (forall X, X \notin L -> type (open_tt T (typ_fvar X))) ->
      type (typ_mu T)
.

Hint Constructors type : core.

Fixpoint subst_tt (Z : atom) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_top => typ_top
  | typ_nat => typ_nat
  | typ_bvar J => typ_bvar J
  | typ_fvar X => if X == Z then U else (typ_fvar X)
  | typ_arrow T1 T2 => typ_arrow (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_mu T => typ_mu (subst_tt Z U T)
  | typ_rcd l T => typ_rcd l (subst_tt Z U T)
  end.

Fixpoint fv_tt (T : typ) {struct T} : atoms :=
  match T with
  | typ_top => {}
  | typ_nat => {}
  | typ_bvar J => {}
  | typ_fvar X => {{ X }}
  | typ_arrow T1 T2 => (fv_tt T1) `union` (fv_tt T2)
  | typ_mu T => (fv_tt T)
  | typ_rcd l T => fv_tt T
  end.

Fixpoint fl_tt (T : typ) {struct T} : atoms :=
  match T with
  | typ_top => {}
  | typ_nat => {}
  | typ_bvar J => {}
  | typ_fvar X => {}
  | typ_arrow T1 T2 => (fl_tt T1) `union` (fl_tt T2)
  | typ_mu T => (fl_tt T)
  | typ_rcd X T => {{ X }} `union` fl_tt T
  end.

Inductive binding : Set :=
  | bind_sub : binding.

Definition env := list (atom * binding).
Notation empty := (@nil (atom * binding)).

Inductive WF : env -> typ -> Prop :=
| WF_top : forall E, WF E typ_top
| WF_nat : forall E, WF E typ_nat
| WF_fvar : forall X E,
    binds X bind_sub E ->
    WF E (typ_fvar X)
| WF_arrow : forall E A B,
    WF E A ->
    WF E B ->
    WF E (typ_arrow A B)
| WF_rcd : forall E l T,
    WF E T ->
    WF E (typ_rcd l T)
| WF_rec : forall L E A,
      (forall  X, X \notin L ->
        WF (X ~ bind_sub ++ E) (open_tt A X)) ->
      WF E (typ_mu A).

Inductive WFS : env -> typ -> Prop :=
| WFS_top : forall E, WFS E typ_top
| WFS_nat : forall E, WFS E typ_nat
| WFS_fvar : forall X E,
    binds X bind_sub E ->
    WFS E (typ_fvar X)
| WFS_arrow : forall E A B,
    WFS E A ->
    WFS E B ->
    WFS E (typ_arrow A B)
| WFS_rcd : forall E l T,
    WFS E T ->
    WFS E (typ_rcd l T)
| WFS_rec : forall L E A,
    (forall  X, X \notin L ->
        WFS (X ~ bind_sub ++ E) (open_tt A (typ_rcd X (open_tt A X)))) ->
      (forall  X, X \notin L ->
        WFS (X ~ bind_sub ++ E) (open_tt A X)) ->
      WFS E (typ_mu A).

Inductive wf_env : env -> Prop :=
  | wf_env_empty :
      wf_env empty
  | wf_env_sub : forall (E : env) (X : atom) ,
      wf_env E ->
      X \notin dom E ->
      wf_env (X ~ bind_sub ++ E)
.

Inductive Sub : env -> typ -> typ -> Prop :=
| S_nat: forall E,
    wf_env E ->
    Sub E typ_nat typ_nat
| S_fvar: forall E X,
    wf_env E ->
    WFS E (typ_fvar X) ->
    Sub E (typ_fvar X) (typ_fvar X)
| S_top : forall E A,
    wf_env E ->
    WFS E A ->
    Sub E A typ_top
| S_arrow: forall E A1 A2 B1 B2,
    Sub E B1 A1 ->
    Sub E A2 B2 ->
    Sub E (typ_arrow A1 A2) (typ_arrow B1 B2)
| S_rec: forall L A1 A2 E,
    (forall X,
        X \notin L -> WFS (X ~ bind_sub ++ E) (open_tt A1 X)) ->
    (forall X,
        X \notin L -> WFS (X ~ bind_sub ++ E) (open_tt A2 X)) ->
    (forall X,
        X \notin L ->
        Sub (X ~ bind_sub ++ E) (open_tt A1 (typ_rcd X (open_tt A1 X))) (open_tt A2 (typ_rcd X (open_tt A2 X)))) ->
    Sub E (typ_mu A1) (typ_mu A2)
| S_rcd : forall A B l E,
    Sub E A B ->
    Sub E (typ_rcd l A) (typ_rcd l B)
.

Inductive sub : env -> typ -> typ -> Prop :=
| Sa_nat: forall E,
    wf_env E ->
    sub E typ_nat typ_nat
| Sa_fvar: forall E X,
    wf_env E ->
    WF E (typ_fvar X) ->
    sub E (typ_fvar X) (typ_fvar X)
| Sa_top : forall E A,
    wf_env E ->
    WF E A ->
    sub E A typ_top
| Sa_arrow: forall E A1 A2 B1 B2,
    sub E B1 A1 ->
    sub E A2 B2 ->
    sub E (typ_arrow A1 A2) (typ_arrow B1 B2)
| Sa_rec: forall L A1 A2 E,
    (forall X,
        X \notin L ->
        sub (X ~ bind_sub ++ E) (open_tt A1 X) (open_tt A2 X)) ->
    (forall X,
        X \notin L ->
        sub (X ~ bind_sub ++ E) (open_tt A1 (open_tt A1 X)) (open_tt A2 (open_tt A2 X))) ->
    sub E (typ_mu A1) (typ_mu A2)
| Sa_rcd : forall A B l E,
    sub E A B ->
    sub E (typ_rcd l A) (typ_rcd l B)
.

Lemma subst_tt_intro_rec : forall X T2 U k,
  X `notin` fv_tt T2 ->
  open_tt_rec k U T2 = subst_tt X U (open_tt_rec k (typ_fvar X) T2).
Proof with congruence || auto.
  induction T2; intros U k Fr; simpl in *; f_equal...

    destruct (k === n)... simpl. destruct (X == X)...

    destruct (a == X)... contradict Fr; fsetdec.
Qed.

Lemma subst_tt_intro : forall X T2 U,
  X `notin` fv_tt T2 ->
  open_tt T2 U = subst_tt X U (open_tt T2 X).
Proof.
  intros.
  unfold open_tt.
  apply subst_tt_intro_rec...
  assumption.
Qed.

Lemma open_tt_rec_type_aux : forall T j V i U,
  i <> j ->
  open_tt_rec j V T = open_tt_rec i U (open_tt_rec j V T) ->
  T = open_tt_rec i U T.
Proof with congruence || eauto.
  induction T; intros j V i U Neq H; simpl in *; inversion H; f_equal...
    destruct (j === n)... destruct (i === n)...
Qed.

Lemma open_tt_rec_type : forall T U k,
  type T ->
  T = open_tt_rec k U T.
Proof with auto.
  intros T U k Htyp. revert k.
  induction Htyp; intros k; simpl; f_equal...

    unfold open_tt in *.
    pick fresh X.
    apply open_tt_rec_type_aux with (j:=0) (V:=X).
    auto.
    auto.
Qed.

Lemma subst_tt_fresh : forall Z U T,
   Z `notin` fv_tt T ->
   T = subst_tt Z U T.
Proof with auto.
  induction T; simpl; intro H; f_equal...

    destruct (a == Z)...
    contradict H; fsetdec.
Qed.

Lemma subst_tt_open_tt_rec : forall T1 T2 X P k,
  type P ->
  subst_tt X P (open_tt_rec k T2 T1) =
    open_tt_rec k (subst_tt X P T2) (subst_tt X P T1).
Proof with auto.
  intros T1 T2 X P k WP. revert k.
  induction T1; intros k; simpl; f_equal...

    destruct (k === n); subst...

    destruct (a == X); subst... apply open_tt_rec_type...
Qed.

Lemma subst_tt_open_tt : forall T1 T2 (X:atom) P,
  type P ->
  subst_tt X P (open_tt T1 T2) = open_tt (subst_tt X P T1) (subst_tt X P T2).
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_tt_open_tt_rec...
Qed.

Lemma subst_tt_open_tt_var : forall (X Y:atom) P T,
  Y <> X ->
  type P ->
  open_tt (subst_tt X P T) Y = subst_tt X P (open_tt T Y).
Proof with congruence || auto.
  intros X Y P T Neq Wu.
  unfold open_tt.
  rewrite subst_tt_open_tt_rec...
  simpl.
  destruct (Y == X)...
Qed.

Lemma subst_tt_type : forall Z P T,
  type T ->
  type P ->
  type (subst_tt Z P T).
Proof with auto.
  intros Z P T HT HP.
  induction HT; simpl...
  destruct (X == Z)...

    pick fresh Y and apply type_mu...
    rewrite subst_tt_open_tt_var...
Qed.

Hint Constructors  WF WFS Sub sub wf_env: core.

Lemma WF_type: forall E A,
    WF E A ->
    type A.
Proof with auto.
  intros.
  induction H...
  apply type_mu with (L:=L)...
Qed.

Lemma WF_weakening: forall E1 E2 T E,
    WF (E1 ++ E2) T ->
    WF (E1 ++ E ++ E2) T.
Proof with auto.
  intros.
  generalize dependent E.
  dependent induction H;intros...
  -
    apply WF_rec with (L:=L)...
    intros.
    rewrite_alist (([(X, bind_sub)] ++ E1) ++ E ++ E2).
    apply H0...
Qed.

Lemma subst_tt_wf: forall A B E X,
    WF E A ->
    WF E B ->
    WF E (subst_tt X A B).
Proof with auto.
  intros.
  generalize dependent A.
  dependent induction H0;intros;simpl in *...
  -
    destruct (X0==X)...
  -
    apply WF_rec with (L:=L \u {{X}} \u fv_tt A0).
    intros.
    rewrite  subst_tt_open_tt_var...
    apply H0...
    rewrite_alist (nil ++ [(X0, bind_sub)] ++ E).
    apply WF_weakening...
    apply WF_type in H1...
Qed.

Lemma wfs_to_wf: forall E A,
    WFS E A ->
    WF E A.
Proof with auto.
  intros.
  induction H...
  apply WF_rec with (L:=L)...
Qed.

Lemma WFS_weakening: forall E1 E2 T E,
    WFS (E1 ++ E2) T ->
    WFS (E1 ++ E ++ E2) T.
Proof with auto.
  intros.
  generalize dependent E.
  dependent induction H;intros...
  -
    apply WFS_rec with (L:=L);intros...
    +
      rewrite_alist (([(X, bind_sub)] ++ E1) ++ E ++ E2).
      apply H0...
    +
      rewrite_alist (([(X, bind_sub)] ++ E1) ++ E ++ E2).
      apply H2...
Qed.

Lemma WFS_type: forall E A,
    WFS E A ->
    type A.
Proof with auto.
  intros.
  induction H...
  apply type_mu with (L:=L)...
Qed.

Lemma rcd_transform2:forall A C (X Y :atom),
    X <> Y -> type C ->
    (open_tt (subst_tt X C A) (typ_rcd Y (open_tt (subst_tt X C A) Y))) = (subst_tt X C (open_tt A (typ_rcd Y (open_tt A Y)))).
Proof with auto.
  intros.
  rewrite subst_tt_open_tt...
  f_equal...
  simpl...
  f_equal...
  rewrite subst_tt_open_tt_var...
Qed.

Lemma subst_tt_wfs: forall A B E X,
    WFS E A ->
    WFS E B ->
    WFS E (subst_tt X A B).
Proof with auto.
  intros.
  generalize dependent A.
  dependent induction H0;intros;simpl in *...
  -
    destruct (X0==X)...
  -
    apply WFS_rec with (L:=L \u {{X}} \u fv_tt A0);intros...
    +
      rewrite rcd_transform2...
      apply H0...
      rewrite_alist (nil ++ [(X0, bind_sub)] ++ E).
      apply WFS_weakening...
      apply WFS_type in H3...
    +
      rewrite  subst_tt_open_tt_var...
      apply H2...
      rewrite_alist (nil ++ [(X0, bind_sub)] ++ E).
      apply WFS_weakening...
      apply WFS_type in H3...
Qed.

Lemma wf_to_wfs: forall E A,
    WF E A ->
    WFS E A.
Proof with auto.
  intros.
  induction H...
  apply WFS_rec with (L:=L \u fv_tt A)...
  intros.
  rewrite subst_tt_intro with (X:=X)...
  apply subst_tt_wfs...
Qed.

Fixpoint subst_label (Z : atom)  (T : typ) {struct T} : typ :=
  match T with
  | typ_top => typ_top
  | typ_nat => typ_nat
  | typ_bvar J => typ_bvar J
  | typ_fvar X =>  (typ_fvar X)
  | typ_arrow T1 T2 => typ_arrow (subst_label Z  T1) (subst_label Z  T2)
  | typ_mu T => typ_mu (subst_label Z  T)
  | typ_rcd l T => if (l==Z) then (typ_fvar Z) else typ_rcd l (subst_label Z  T)
  end.

Lemma subst_label_open_tt_rec : forall T1 T2 X  k,

  subst_label X  (open_tt_rec k T2 T1) =
    open_tt_rec k (subst_label X  T2) (subst_label X  T1).
Proof with auto.
  intros T1.
  induction T1; intros ; simpl in *; f_equal...

    destruct (k === n); subst...

    destruct (a == X); subst...
    simpl.
    f_equal...
Qed.

Lemma subst_label_open_tt : forall T1 T2 (X:atom),
  subst_label X  (open_tt T1 T2) = open_tt (subst_label X  T1) (subst_label X  T2).
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_label_open_tt_rec...
Qed.

Lemma subst_label_open_tt_var : forall T1 (Y X:atom),
  subst_label X  (open_tt T1 Y) = open_tt (subst_label X  T1) Y.
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_label_open_tt_rec...
Qed.

Lemma subst_label_wfs: forall E1 E2 A X,
    WF (E1++ [(X, bind_sub)] ++ E2) A ->
    WF (E1 ++ [(X, bind_sub)] ++ E2) (subst_label X A).
Proof with auto.
  intros.
  dependent induction H; simpl in *...
  -
    destruct (l==X)...
  -
    apply WF_rec with (L:=L \u {{X}});intros...
    rewrite <- subst_label_open_tt_var ...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ (X, bind_sub) :: E2).
    apply H0...
Qed.

Lemma label_transform2: forall A X X0,
    X <> X0 ->
    (subst_label X (open_tt A (typ_rcd X0 (open_tt A X0)))) =
(open_tt (subst_label X A) (typ_rcd X0 (open_tt (subst_label X A) X0))).
Proof with auto.
  intros.
  rewrite subst_label_open_tt...
  f_equal...
  simpl...
  destruct (X0==X)...
  destruct H...
  f_equal...
  rewrite subst_label_open_tt...
Qed.

Lemma sub_regular : forall  E A B,
    sub E A B ->
    WF E A /\ WF E B /\ wf_env E.
Proof with auto.
  intros.
  dependent induction H;try solve [destruct_hypos;repeat split;auto]...
  split.
  apply WF_rec with (L:=L)...
  intros.
  apply H0 in H3.
  destruct_hypos...
  split.
  apply WF_rec with (L:=L)...
  intros.
  apply H0 in H3.
  destruct_hypos...
  pick fresh X.
  specialize_x_and_L X L.
  destruct_hypos.
  inversion H4...
Qed.

Lemma Sub_regular : forall  E A B,
    Sub E A B ->
    WFS E A /\ WFS E B /\ wf_env E.
Proof with auto.
  intros.
  dependent induction H;try solve [destruct_hypos;repeat split;auto]...
  split.
  apply WFS_rec with (L:=L);intros...
  eapply H2...
  split.
  apply WFS_rec with (L:=L);intros...
  eapply H2...
  pick fresh X.
  specialize_x_and_L X L.
  destruct_hypos.
  inversion H4...
Qed.

Lemma open_twice_to_one: forall E1 E2 A B X,
    sub (E1++ [(X, bind_sub)] ++ E2) A B ->
    sub (E1++ [(X, bind_sub)] ++ E2) (subst_label X A) (subst_label X B).
Proof with eauto using subst_label_wfs.
  intros.
  dependent induction H;try solve [simpl in *;auto]...
  -
    simpl in *.
    apply Sa_rec with (L:=L \u fv_tt A1 \u fv_tt A2 \u {{X}});intros.
    rewrite <- subst_label_open_tt_var...
    rewrite <- subst_label_open_tt_var...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ (X, bind_sub) :: E2).
    apply H0...
    rewrite <- subst_label_open_tt_var...
    rewrite <- subst_label_open_tt_var...
    rewrite <- subst_label_open_tt...
    rewrite <- subst_label_open_tt...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ (X, bind_sub) :: E2).
    apply H2...
  -
    simpl in *.
    destruct (l==X)...
    constructor...
    apply sub_regular in H.
    destruct_hypos...
Qed.

Lemma label_transform: forall A X B ,
    X \notin fl_tt A ->
    subst_label X (open_tt A (typ_rcd X B) ) = open_tt A X .
Proof with auto.
  intro A.
  unfold open_tt.
  generalize 0.
  induction A;intros;simpl in *;try solve [f_equal;auto]...
  -
    destruct (n0==n)...
    simpl...
    destruct (X==X)...
    destruct n1...
  -
    destruct (a==X)...
    subst.
    apply notin_union in H.
    destruct H.
    apply notin_singleton_1 in H.
    destruct H...
    f_equal...
Qed.

Lemma WF_subst_rcd: forall E A,
    WF E A ->
    forall X B,
      type B ->
    WF E (subst_tt X (typ_rcd X B) A) ->
    WF E (subst_tt X B A).
Proof with auto.
  intros E A H.
  induction H;intros;simpl in *...
  -
    destruct (X==X0)...
    inversion H1...
  -
    dependent destruction H2...
  -
    dependent destruction H1...
  -
    dependent destruction H2...
    apply WF_rec with (L:=L \u L0 \u fv_tt A \u fv_tt B \u {{X}}).
    intros.
    rewrite subst_tt_open_tt_var...
    apply H0...
    rewrite <- subst_tt_open_tt_var...
    apply H2...
Qed.

Lemma sub_subst_rcd: forall E A B,
    sub E A B ->
    forall X C D,
      sub E (subst_tt X (typ_rcd X C) A) (subst_tt X (typ_rcd X D) B) ->
      type C -> type D ->
      sub E (subst_tt X C A) (subst_tt X D B).
Proof with auto.
  intros E A B H.
  induction H;intros...
  -
    simpl in *.
    destruct (X==X0)...
    dependent destruction H1...
  -
    simpl in *.
    constructor...
    apply sub_regular in H1.
    destruct_hypos.
    apply WF_subst_rcd...
  -
    simpl in *...
    dependent destruction H1...
  -
    simpl in *.
    dependent destruction H3...
    apply Sa_rec with (L:=L \u L0 \u {{X}} \u fv_tt A1 \u fv_tt A2);intros.
    +
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      apply H0...
      rewrite <- subst_tt_open_tt_var...
      rewrite <- subst_tt_open_tt_var...
      apply H3...
    +
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite <- subst_tt_open_tt...
      rewrite <- subst_tt_open_tt...
      apply H2...
      rewrite  subst_tt_open_tt...
      rewrite <- subst_tt_open_tt_var...
      rewrite  subst_tt_open_tt...
      rewrite <- subst_tt_open_tt_var...
      apply H4...
  -
    simpl in *...
    dependent destruction H0...
Qed.

Lemma rcd_transform: forall A B (X Y :atom),
    X <> Y -> type B -> type (open_tt A Y) ->
    subst_tt X (typ_rcd X B) (open_tt A (typ_rcd Y (open_tt A Y))) =
  open_tt (subst_tt X (typ_rcd X B) A) (typ_rcd Y (open_tt (subst_tt X (typ_rcd X B) A) Y)).
Proof with auto.
  intros.
  rewrite subst_tt_open_tt...
  f_equal...
  simpl...
  f_equal...
  rewrite subst_tt_open_tt...
  f_equal...
  rewrite <- subst_tt_fresh...
Qed.

Lemma Sub_subst_rcd: forall E A B,
    Sub E A B ->
    forall X C D,
      Sub E (subst_tt X C A) (subst_tt X D B) ->
      WFS E C -> WFS E D ->
      Sub E (subst_tt X (typ_rcd X C) A) (subst_tt X (typ_rcd X D) B).
Proof with auto.
  intros E A B H.
  induction H;intros...
  -
    simpl in *.
    destruct (X==X0)...
  -
    simpl in *.
    constructor...
    apply subst_tt_wfs...
  -
    simpl in *...
    dependent destruction H1...
  -
    simpl in *.
    dependent destruction H3...
    apply S_rec with (L:=L \u L0 \u {{X}} \u fv_tt A1 \u fv_tt A2);intros.
    +
      rewrite subst_tt_open_tt_var...
      apply subst_tt_wfs...
      constructor.
      rewrite_alist (nil ++ [(X0, bind_sub)] ++ E).
      apply WFS_weakening...
      apply H...
      constructor.
      apply WFS_type in H6...
    +
      rewrite subst_tt_open_tt_var...
      apply subst_tt_wfs...
      constructor.
      rewrite_alist (nil ++ [(X0, bind_sub)] ++ E).
      apply WFS_weakening...
      apply H0...
      constructor.
      apply WFS_type in H7...
    +
      assert (type C).
      apply WFS_type in H6...
      assert (type D).
      apply WFS_type in H7...
      rewrite <- rcd_transform...
      rewrite <- rcd_transform...
      apply H2...
      rewrite <- rcd_transform2...
      rewrite <- rcd_transform2...
      apply H5...
      rewrite_alist (nil ++ [(X0, bind_sub)] ++ E).
      apply WFS_weakening...
      rewrite_alist (nil ++ [(X0, bind_sub)] ++ E).
      apply WFS_weakening...
      specialize_x_and_L X0 L.
      apply WFS_type in H0...
      specialize_x_and_L X0 L.
      apply WFS_type in H...
  -
    simpl in *...
    dependent destruction H0...
Qed.

Lemma sub_to_Sub: forall E A B,
    sub E A B ->
    Sub E A B.
Proof with auto.
  intros.
  induction H;try solve [constructor;auto;apply wf_to_wfs;auto]...
  apply S_rec with (L:=L \u fv_tt A1 \u fv_tt A2);intros...
  -
    specialize_x_and_L X L.
    apply Sub_regular in H0.
    destruct_hypos...
  -
    specialize_x_and_L X L.
    apply Sub_regular in H0.
    destruct_hypos...
  -
    rewrite subst_tt_intro with (X:=X)...
    remember (subst_tt X (typ_rcd X (open_tt A1 X)) (open_tt A1 X)).
    rewrite subst_tt_intro with (X:=X)...
    subst.
    apply Sub_subst_rcd...
    rewrite <- subst_tt_intro...
    rewrite <- subst_tt_intro...
    specialize_x_and_L X L.
    apply Sub_regular in H0.
    destruct_hypos...
    specialize_x_and_L X L.
    apply Sub_regular in H0.
    destruct_hypos...
Qed.

Lemma open_twice_to_once: forall E1 E2 X A1 A2,
     sub (E1 ++ [(X, bind_sub)] ++ E2) (open_tt A1 (typ_rcd X (open_tt A1 X)))
         (open_tt A2 (typ_rcd X (open_tt A2 X))) ->
     X \notin fl_tt A1 \u fl_tt A2 ->
     sub (E1 ++ [(X, bind_sub)] ++ E2) (open_tt A1 X) (open_tt A2 X).
Proof with auto.
  intros.
  apply open_twice_to_one in H...
  rewrite label_transform in H...
  rewrite label_transform in H...
Qed.

Lemma Sub_to_sub: forall E A B,
    Sub E A B ->
    sub E A B.
Proof with auto.
  intros.
  induction H;try solve [constructor;auto;apply wfs_to_wf;auto]...
  apply Sa_rec with (L:=L \u fl_tt A1 \u fl_tt A2 \u fv_tt A1 \u fv_tt A2);intros...
  -
    specialize_x_and_L X L.
    rewrite_alist (nil ++ [(X, bind_sub)] ++ E) in H2.
    apply open_twice_to_once in H2...
  -
    assert (Hq:=H2).
    specialize_x_and_L X L.
    rewrite_alist (nil ++ [(X, bind_sub)] ++ E) in H2.
    apply open_twice_to_once in H2...
    apply sub_subst_rcd with (X:=X) (C:=open_tt A1 X) (D:=open_tt A2 X) in H2...
    rewrite <- subst_tt_intro in H2...
    rewrite <- subst_tt_intro in H2...
    rewrite <- subst_tt_intro...
    rewrite <- subst_tt_intro...
    apply WFS_type in H...
    apply WFS_type in H0...
Qed.

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : typ => fv_tt x) in
  let D := gather_atoms_with (fun x : typ => fl_tt x) in
  let F := gather_atoms_with (fun x : env => dom x) in
  constr:(A `union` B `union` C \u D \u F).

Lemma label_transform3: forall A (X X0 Y : atom),
    X <> X0 ->
    (subst_tt X Y (open_tt A (typ_rcd X0 (open_tt A X0)))) =
(open_tt (subst_tt X Y A) (typ_rcd X0 (open_tt (subst_tt X Y A) X0))).
Proof with auto.
  intros.
  rewrite  subst_tt_open_tt...
  f_equal...
  simpl.
  f_equal...
  rewrite  subst_tt_open_tt_var...
Qed.

Lemma WFS_replacing: forall E1 E2 T X Y,
    WFS (E1++ X ~ bind_sub ++E2) T ->
    X <> Y ->
    WFS (E1++ Y ~ bind_sub ++E2) (subst_tt X Y T).
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros;simpl;try solve [rewrite_alist (E1 ++ Y ~ bind_sub ++ E2);constructor;auto]...
  -
    destruct (X0==X)...
    constructor.
    analyze_binds H.
  -
    apply WFS_rec with (L:=L \u {{X}});intros.
    rewrite <- label_transform3...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ Y ~ bind_sub ++ E2).
    apply H0...
    rewrite  subst_tt_open_tt_var...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ Y ~ bind_sub ++ E2).
    apply H2...
Qed.

Lemma WFS_replacing_var: forall E T X Y,
    WFS (X ~ bind_sub ++E) (open_tt T X) ->
    X \notin fv_tt T \u {{Y}} ->
    WFS (Y ~ bind_sub ++E) (open_tt T Y).
Proof with auto.
  intros.
  rewrite_alist (nil ++ [(Y, bind_sub)] ++ E).
  rewrite subst_tt_intro with (X:=X)...
  apply WFS_replacing...
Qed.

Lemma Sub_replacing: forall E1 E2 A B X Y,
    Sub (E1++ X ~ bind_sub ++E2) A B ->
    X <> Y ->
    wf_env (E1 ++ Y ~ bind_sub ++ E2) ->
    Sub (E1++ Y ~ bind_sub ++E2) (subst_tt X Y A) (subst_tt X Y B).
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros;simpl;try solve [rewrite_alist (E1 ++ [(Y, bind_sub)] ++ E2);constructor;auto;apply  WFS_replacing;auto]...
  -
    destruct (X0==X)...
    constructor...
    constructor...
    dependent destruction H0.
    analyze_binds H0.
  -
    apply S_rec with (L:=L  \u {{X}} \u dom (E1 ++ [(Y, bind_sub)] ++ E2) );intros...
    rewrite  subst_tt_open_tt_var...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ Y ~ bind_sub ++ E2).
    apply WFS_replacing...
    rewrite_alist ([(X0, bind_sub)] ++ E1 ++ [(X, bind_sub)] ++ E2)...
    rewrite  subst_tt_open_tt_var...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ Y ~ bind_sub ++ E2).
    apply WFS_replacing...
    rewrite_alist ([(X0, bind_sub)] ++ E1 ++ [(X, bind_sub)] ++ E2)...
    rewrite <- label_transform3...
    rewrite <- label_transform3...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ Y ~ bind_sub ++ E2).
    apply H2...
    rewrite_alist ([(X0, bind_sub)] ++ E1 ++ [(Y, bind_sub)] ++ E2).
    constructor...
Qed.

Fixpoint subst_tl (Z : atom) (U : atom) (T : typ) {struct T} : typ :=
  match T with
  | typ_top => typ_top
  | typ_nat => typ_nat
  | typ_bvar J => typ_bvar J
  | typ_fvar X => typ_fvar X
  | typ_arrow T1 T2 => typ_arrow (subst_tl Z U T1) (subst_tl Z U T2)
  | typ_mu T => typ_mu (subst_tl Z U T)
  | typ_rcd l T => if (l==Z) then typ_rcd U (subst_tl Z U T) else typ_rcd l (subst_tl Z U T)
  end.

Lemma label_transform1: forall (X Y:atom) A,
    X \notin fv_tt A ->
    (subst_tt X Y (open_tt A (typ_rcd X (open_tt A X)))) =
    (open_tt A (typ_rcd X (open_tt A Y))).
Proof with auto.
  intros.
  rewrite subst_tt_open_tt...
  simpl...
  rewrite <- subst_tt_intro...
  f_equal...
  rewrite <- subst_tt_fresh...
Qed.

Lemma subst_tl_open_tt_rec : forall Z  A (X Y : atom) k,
    subst_tl X Y (open_tt_rec k A Z) = open_tt_rec k (subst_tl X Y A) (subst_tl X Y Z).
Proof with auto.
  intros Z.
  induction Z;intros ; simpl in *; f_equal...
  -
    destruct (k==n)...
  -
    destruct (a==X);subst;simpl...
    f_equal...
    f_equal...
Qed.

Lemma subst_tl_open_tt : forall A Z (X Y : atom),
    subst_tl X Y (open_tt A Z) = open_tt (subst_tl X Y A) (subst_tl X Y Z).
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_tl_open_tt_rec...
Qed.

Lemma label_transform4: forall A (X X0 Y : atom),
    X <> X0 ->
    (subst_tl X Y (open_tt A (typ_rcd X0 (open_tt A X0)))) =
(open_tt (subst_tl X Y A) (typ_rcd X0 (open_tt (subst_tl X Y A) X0))).
Proof with auto.
  intros.
  rewrite  subst_tl_open_tt...
  f_equal...
  simpl.
  destruct (X0==X);subst...
  destruct H...
  f_equal...
  rewrite subst_tl_open_tt...
Qed.

Lemma subst_tl_open_tt_var : forall A (X Y Z: atom),
    subst_tl X Y (open_tt A Z) = open_tt (subst_tl X Y A) Z.
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_tl_open_tt_rec...
Qed.

Lemma WFS_replacing2: forall E T X Y,
    WFS E T ->
    X <> Y ->
    WFS E (subst_tl X Y T).
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros;simpl;try solve [constructor;auto]...
  -
    destruct (l==X);subst...
  -
    apply WFS_rec with (L:=L \u {{X}});intros.
    rewrite <- label_transform4...
    rewrite <- subst_tl_open_tt_var...
Qed.

Lemma Sub_replacing2: forall E A B X Y,
    Sub E A B ->
    X <> Y ->
    Sub E (subst_tl X Y A) (subst_tl X Y B).
Proof with eauto using WFS_replacing2.
  intros.
  generalize dependent Y.
  dependent induction H;intros;simpl;try solve [constructor;auto]...
  -
    apply S_rec with (L:=L  \u {{X}} \u dom E );intros...
    rewrite <- subst_tl_open_tt_var...
    rewrite <- subst_tl_open_tt_var...
    rewrite <- label_transform4...
    rewrite <- label_transform4...
  -
    destruct (l==X);subst...
Qed.

Lemma subst_tl_fresh: forall A X Y,
    X `notin` fl_tt A ->
    subst_tl X Y A = A.
Proof with auto.
  induction A;intros;simpl in *;try solve [f_equal;auto]...
  destruct (a==X);subst...
  apply notin_union in H.
  destruct H.
  apply notin_singleton_1 in H...
  destruct H...
  f_equal...
Qed.

Lemma notin_fl_tt_open : forall X U T,
    X `notin` fl_tt T ->
    X \notin fl_tt U ->
    X `notin` fl_tt (open_tt T U).
Proof with auto.
  intros.
  unfold open_tt.
  unfold open_tt_rec.
  generalize 0.
  induction T;simpl in *;intros...
  destruct (n0==n)...
Qed.

Lemma label_transform5: forall (X Y Z:atom) A,
    X \notin fl_tt A ->
    (subst_tl X Y (open_tt A (typ_rcd X (open_tt A Z)))) =
    (open_tt A (typ_rcd Y (open_tt A Z))).
Proof with auto.
  intros.
  rewrite subst_tl_open_tt...
  simpl...
  destruct (X==X)...
  f_equal...
  apply subst_tl_fresh...
  f_equal...
  apply subst_tl_fresh...
  apply notin_fl_tt_open...
  destruct n...
Qed.

Lemma Sub_replacing_open: forall E1 E2 A B X Y,
    Sub (E1 ++X ~ bind_sub ++E2) (open_tt A (typ_rcd X (open_tt A X))) (open_tt B (typ_rcd X (open_tt B X)))  ->
    Y \notin {{X}} \u fv_tt A \u fv_tt B ->
    X \notin fv_tt A \u fv_tt B \u fl_tt A \u fl_tt B ->
    wf_env (E1 ++ [(Y, bind_sub)] ++ E2) ->
    Sub (E1++ Y ~ bind_sub ++E2) (open_tt A (typ_rcd Y (open_tt A Y))) (open_tt B (typ_rcd Y (open_tt B Y))).
Proof with auto.
  intros.
  apply Sub_replacing with (Y:=Y) in H...
  rewrite label_transform1 in H...
  rewrite label_transform1 in H...
  apply Sub_replacing2 with (X:=X) (Y:=Y) in H...
  rewrite label_transform5 in H...
  rewrite label_transform5 in H...
Qed.

Lemma sub_refl : forall E A ,
    wf_env E -> WFS E A -> Sub E A A.
Proof with auto.
  intros.
  induction H0...
  apply S_rec with (L:=L \u dom E);intros...
Qed.

Ltac solve_by_inv H H1 := dependent destruction H;dependent destruction H1;auto.
Ltac get_well_form :=
    repeat match goal with
           | [ H : Sub _ _ _ |- _ ] => apply Sub_regular in H;destruct_hypos
           end.

Lemma trans_aux: forall B E,
    WFS E B -> forall A C,
    Sub E A B -> Sub E B C -> Sub E A C.
Proof with auto.
  intros B E H.
  dependent induction H;intros;try solve [solve_by_inv H0 H|solve_by_inv H H0|solve_by_inv H0 H2]...
  -
    dependent destruction H1...
    dependent destruction H2...
    constructor...
    get_well_form...
  -
    dependent destruction H1.
    constructor...
    get_well_form...
    dependent destruction H0...
  -
    dependent destruction H3.
    dependent destruction H6...
    constructor...
    apply WFS_rec with (L:=L0 \u L)...
    intros...
    specialize_x_and_L X L0.
    get_well_form...
    apply S_rec with (L:=L \u L0 \u L1)...
Qed.

Lemma Transitivity: forall B E A C,
    Sub E A B -> Sub E B C -> Sub E A C.
Proof with auto.
  intros.
  apply trans_aux with (B:=B)...
  get_well_form...
Qed.

Definition choose (m : Mode)  (C : typ) (D : typ) :=
  match m with
  | Pos => C
  | Neg => D
  end.

Lemma choose_flip: forall m A B ,
    choose m A B = choose (flip m) B A .
Proof with auto.
  intros.
  destruct m...
Qed.

Lemma WFS_permutation : forall A B C D  T ,
    WFS ( A ++ B ++ C ++ D ) T ->
    WFS ( A ++ C ++ B ++ D) T.
Proof with auto.
  intros.
  dependent induction H...
  -
    constructor...
    analyze_binds H...
  -
    apply WFS_rec with (L:=L);intros;
      rewrite_alist (([(X, bind_sub)]  ++ A) ++ C ++ B ++ D)...
Qed.

Lemma Sub_permutation: forall A B C D S T,
    Sub (A ++ B ++ C ++ D) S T ->
    wf_env (A ++ C ++ B ++ D) ->
    Sub (A ++ C ++ B ++ D) S T.
Proof with auto using WFS_permutation.
   intros.
   dependent induction H...
   -
     apply S_rec with (L:=L \u dom (A ++ B++C ++D) );intros;
     rewrite_alist (([(X, bind_sub)]  ++ A) ++ C ++ B ++ D)...
     apply WFS_permutation...
     rewrite_alist ([(X, bind_sub)]  ++ A ++ B ++ C ++ D)...
     apply WFS_permutation...
     rewrite_alist ([(X, bind_sub)]  ++ A ++ B ++ C ++ D)...
     apply H2...
     rewrite_alist ([(X, bind_sub)]  ++ A ++ C ++ B ++ D)...
Qed.

Lemma Sub_subst_rcd_dismiss: forall E E1 A B X C D,
    X `notin` fl_tt A \u fl_tt B ->
    Sub (E1++[(X, bind_sub)] ++ E) (subst_tt X (typ_rcd X C) A)
        (subst_tt X (typ_rcd X D) B) ->
    type C -> type D ->
    WFS (E1 ++ [(X, bind_sub)] ++ E) A ->
    WFS (E1 ++ [(X, bind_sub)] ++ E) B ->
    Sub (E1++[(X, bind_sub)] ++ E) A B.
Proof with auto.
  intros.
  dependent induction H0;try solve [simpl in *;auto]...
  -
    induction A;try solve [simpl in *;inversion x0|simpl in *;destruct (a==X);inversion x0]...
    induction B;try solve [simpl in *;inversion x|simpl in *;destruct (a==X);inversion x]...
  -
    induction A;try solve [simpl in *;inversion x0|simpl in *;destruct (a==X);inversion x0]...
    induction B;try solve [simpl in *;inversion x|simpl in *;destruct (a==X);inversion x]...
    simpl in *.
    destruct (a==X);destruct (a0==X);try solve [inversion x0|inversion x]...
    rewrite <-x0.
    rewrite <-x.
    apply sub_refl...
  -
    induction B;try solve [simpl in *;inversion x|simpl in *;destruct (a==X);inversion x]...
  -
    induction A;try solve [simpl in *;inversion x0|simpl in *;destruct (a==X);inversion x0]...
    induction B;try solve [simpl in *;inversion x|simpl in *;destruct (a==X);inversion x]...
    clear IHB1 IHB2 IHA1 IHA2.
    simpl in *.
    inversion x0.
    inversion x.
    dependent destruction H3.
    dependent destruction H4.
    constructor...
    apply IHSub1 with (C:=D) (D:=C)...
    apply IHSub2 with (C:=C) (D:=D)...
  -
    induction A;try solve [simpl in *;inversion x0|simpl in *;destruct (a==X);inversion x0]...
    induction B;try solve [simpl in *;inversion x|simpl in *;destruct (a==X);inversion x]...
    clear IHA IHB.
    simpl in *.
    inversion x0.
    inversion x.
    dependent destruction H6.
    dependent destruction H8.
    apply S_rec with (L:=L \u L0 \u L1 \u fv_tt A \u fv_tt B \u {{X}} \u fv_tt C
                     \u fv_tt D \u dom (E1 ++(X~ bind_sub)++ E));intros...
    rewrite_alist  (([(X0, bind_sub)] ++ E1) ++ (X, bind_sub) :: E).
    apply H2 with (X0:=X0) (C:=C) (D:=D)...
    *
      apply notin_union...
      split;apply notin_fl_tt_open;simpl.
      auto.
      apply notin_union.
      split...
      apply notin_fl_tt_open...
      auto.
      apply notin_union.
      split...
      apply notin_fl_tt_open...
    *
      subst.
      rewrite  subst_tt_open_tt...
      f_equal...
      simpl...
      f_equal...
      rewrite  subst_tt_open_tt_var...
    *
      subst.
      rewrite  subst_tt_open_tt...
      f_equal...
      simpl...
      f_equal...
      rewrite  subst_tt_open_tt_var...
    *
      apply H6...
    *
      apply H8...
  -
    induction A;try solve [simpl in *;inversion x0|simpl in *;destruct (a==X);inversion x0];
    induction B;try solve [simpl in *;inversion x|simpl in *;destruct (a==X);inversion x]...
    +
      simpl in *.
      destruct (a==X);destruct (a0==X);try solve [inversion x|inversion x0]...
      inversion x.
      inversion x0;subst.
      apply sub_refl...
      get_well_form...
    +
      clear IHB.
      simpl in *.
      destruct (a==X);subst;try solve [inversion x0]...
      inversion x0.
      inversion x;subst...
      apply notin_union in H.
      destruct H.
      apply notin_union in H5.
      destruct H5.
      apply test_solve_notin_7 in H5...
      destruct H5.
    +
      clear IHA.
      simpl in *.
      destruct (a0==X);subst;try solve [inversion x]...
      inversion x0.
      inversion x;subst...
      apply notin_union in H.
      destruct H.
      apply notin_union in H.
      destruct H.
      apply test_solve_notin_7 in H...
      destruct H.
    +
      clear IHA IHB.
      simpl in *.
      inversion x0.
      inversion x;subst...
      constructor...
      apply IHSub with (C0:=C) (D0:=D)...
      dependent destruction H3...
      dependent destruction H4...
Qed.

Lemma Sub_twice_to_one: forall E E1 A B X,
    X `notin` fl_tt A \u fl_tt B \u fv_tt A \u fv_tt B ->
    Sub (E1++[(X, bind_sub)] ++ E) (open_tt A (typ_rcd X (open_tt A X)))
        (open_tt B (typ_rcd X (open_tt B X))) ->
    WFS (E1 ++ [(X, bind_sub)] ++ E) (open_tt A X) ->
    WFS (E1 ++ [(X, bind_sub)] ++ E) (open_tt B X) ->
    Sub (E1++[(X, bind_sub)] ++ E) (open_tt A X) (open_tt B X).
Proof with auto.
  intros.
  rewrite subst_tt_intro with (X:=X) in H0...
  remember (subst_tt X (typ_rcd X (open_tt A X)) (open_tt A X)).
  rewrite subst_tt_intro with (X:=X) in H0...
  subst.
  apply Sub_subst_rcd_dismiss in H0...
  apply notin_union.
  split.
  apply notin_fl_tt_open...
  apply notin_fl_tt_open...
  apply WFS_type in H1...
  apply WFS_type in H2...
Qed.

Lemma Sub_weakening: forall E E1 E2 A B,
    Sub (E1++E2) A B ->
    wf_env (E1 ++ E ++ E2) ->
    Sub (E1++E++E2) A B.
Proof with eauto using WFS_weakening.
  intros.
  generalize dependent E.
  dependent induction H;intros...
  apply S_rec with (L:=L \u dom (E1 ++ E ++ E2));intros...
  rewrite_alist (([(X, bind_sub)] ++ E1) ++ E ++ E2).
  apply WFS_weakening...
  rewrite_alist ([(X, bind_sub)] ++ E1 ++ E2)...
  rewrite_alist (([(X, bind_sub)] ++ E1) ++ E ++ E2).
  apply WFS_weakening...
  rewrite_alist ([(X, bind_sub)] ++ E1 ++ E2)...
  rewrite_alist (([(X, bind_sub)] ++ E1) ++ E ++ E2).
  apply H2...
  rewrite_alist ([(X, bind_sub)] ++ E1 ++ E ++ E2)...
Qed.

Lemma subst_tt_equiv: forall E A B,
    Sub E A B -> forall C D X,
    Sub E C D -> Sub E D C ->
    Sub E (subst_tt X (typ_rcd X C) A) (subst_tt X (typ_rcd X D) B).
Proof with auto.
  intros E A B H.
  induction H;intros;destruct_hypos;simpl in *;try solve [constructor]...
  -
    destruct (X==X0)...
  -
    constructor...
    get_well_form.
    apply subst_tt_wfs...
  -
    apply S_rec with (L:=L \u {{X}} \u dom E);intros.
    +
      rewrite subst_tt_open_tt_var...
      apply subst_tt_wfs...
      get_well_form.
      constructor...
      rewrite_alist (nil ++ [(X0, bind_sub)] ++ E).
      apply WFS_weakening...
      apply H...
      get_well_form...
      apply WFS_type in H3...
    +
      rewrite subst_tt_open_tt_var...
      apply subst_tt_wfs...
      get_well_form.
      constructor...
      rewrite_alist (nil ++ [(X0, bind_sub)] ++ E).
      apply WFS_weakening...
      apply H0...
      get_well_form...
      apply WFS_type in H8...
    +
      rewrite <-rcd_transform...
      rewrite <- rcd_transform...
      apply H2...
      rewrite_alist (nil ++ (X0 ~ bind_sub) ++ E).
      apply Sub_weakening...
      simpl.
      constructor...
      get_well_form...
      rewrite_alist (nil ++ (X0 ~ bind_sub) ++ E).
      apply Sub_weakening...
      simpl.
      constructor...
      get_well_form...
      get_well_form...
      apply WFS_type in H8...
      specialize_x_and_L X0 L.
      apply WFS_type in H0...
      get_well_form...
      apply WFS_type in H3...
      specialize_x_and_L X0 L.
      apply WFS_type in H...
Qed.

Lemma wf_env_weakening: forall E1 E2 X,
    wf_env (E1++E2) ->
    X \notin dom (E1++E2) ->
    wf_env (E1 ++ (X~bind_sub) ++ E2).
Proof with auto.
  intros E1.
  induction E1;intros...
  constructor...
  destruct a.
  rewrite_alist ((a, b) :: E1 ++ E2) in H.
  rewrite_alist ((a, b) :: E1 ++ [(X, bind_sub)] ++ E2).
  dependent destruction H.
  constructor...
Qed.

Lemma subst_tt_rcd: forall  Y X A B,
    (typ_rcd X (subst_tt Y A B)) = subst_tt Y A (typ_rcd X B).
Proof with auto.
  intros...
Qed.
Lemma subst_tt_wfs3: forall  B E1 E2 X A,
    WFS (E1 ++ (X ~ bind_sub) ++ E2) B ->
    WFS (E1 ++ E2 ) A ->
    X \notin fv_tt A ->
    WFS (E1 ++ E2) (subst_tt X A B).
Proof with auto.
  intros.
  dependent induction H;intros;simpl in *...
  -
    destruct (X0==X)...
    analyze_binds H...
  -
    assert (type A).
    apply WFS_type in H3...
    apply WFS_rec with (L:=L \u {{X}} \u fv_tt A );intros.
    rewrite  subst_tt_open_tt_var...
    rewrite  subst_tt_rcd.
    rewrite  <- subst_tt_open_tt...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ E2).
    apply H0...
    rewrite_alist (nil ++ [(X0, bind_sub)] ++ (E1 ++ E2)).
    apply WFS_weakening...
    rewrite  subst_tt_open_tt_var...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ E2).
    apply H2...
    rewrite_alist (nil ++ [(X0, bind_sub)] ++ (E1 ++ E2)).
    apply WFS_weakening...
Qed.

Lemma mu_transform_1: forall C D (Y X:atom) A m,
    type (typ_mu (choose m C D)) ->
    X <> Y ->
    (subst_tt X (typ_mu (choose m C D)) (open_tt A (typ_rcd Y (open_tt A Y)))) =
 (open_tt (subst_tt X (typ_mu (choose m C D)) A)
       (typ_rcd Y (open_tt (subst_tt X (typ_mu (choose m C D)) A) Y))).
Proof with auto.
  intros.
  rewrite subst_tt_open_tt...
  f_equal.
  simpl...
  f_equal.
  rewrite subst_tt_open_tt_var...
Qed.

Lemma mu_transform_2: forall (X Y:atom) C D A m,
    type (typ_rcd X (choose m (open_tt C X) (open_tt D X))) ->
     X <> Y ->
    open_tt (subst_tt X (typ_rcd X (choose m (open_tt C X) (open_tt D X))) A)
    (typ_rcd Y (open_tt (subst_tt X (typ_rcd X (choose m (open_tt C X) (open_tt D X))) A) Y)) =
  subst_tt X (typ_rcd X (choose m (open_tt C X) (open_tt D X)))
    (open_tt A (typ_rcd Y (open_tt A Y))).
Proof with auto.
  intros.
  rewrite subst_tt_open_tt...
  f_equal...
  simpl...
  f_equal...
  rewrite subst_tt_open_tt_var...
Qed.

Lemma sub_generalize_intensive : forall E1 E2 A B C D X m,
    Sub (E1 ++ X ~ bind_sub ++ E2) A B ->
    X \notin fv_tt C \u fv_tt D \u fl_tt A \u fl_tt B \u dom (E1++E2)->
    Sub (E1 ++ X ~ bind_sub ++ E2) (subst_tt X (typ_rcd X (choose m (open_tt C X) (open_tt D X))) A)
    (subst_tt X (typ_rcd X (choose m (open_tt D X) (open_tt C X))) B) ->
    Sub (E1 ++ E2) (typ_mu C) (typ_mu D) ->
    wf_env (E1++E2) ->
    Sub (E1 ++ E2) (subst_tt X (typ_mu (choose m C D)) A) (subst_tt X (typ_mu (choose m D C)) B).
Proof with auto.
  intros.
  generalize dependent m.
  dependent induction H;intros;simpl...
  -
    destruct (X0==X);subst...
    +
      assert (WFS (E1 ++ E2) (typ_mu C)) by (get_well_form;auto).
      assert (WFS (E1 ++ E2) (typ_mu D)) by (get_well_form;auto).
      destruct m...
      simpl in *...
      destruct (X==X)...
      dependent destruction H2.
      pick fresh Y.
      specialize_x_and_L Y L.
      rewrite_alist (nil ++  [(Y, bind_sub)] ++ E1 ++ E2) in H4...
      apply Sub_permutation in H4...
      apply Sub_twice_to_one in H4...
      dependent destruction H6.
      dependent destruction H7.
      dependent destruction H9.
      apply S_rec with (L:=fv_tt D \u fv_tt C \u fl_tt C \u fl_tt D \u {{X}} \u {{Y}} \u L1 \u L0 \u dom (E1++E2));intros...
      rewrite subst_tt_intro with (X:=X0)...
      remember (subst_tt X0 (typ_rcd X0 (open_tt D X0)) (open_tt D X0)).
      rewrite subst_tt_intro with (X:=X0)...
      subst.
      apply subst_tt_equiv...
      *
        rewrite subst_tt_intro with (X:=X)...
        remember (subst_tt X X0 (open_tt D X)).
        rewrite subst_tt_intro with (X:=X)...
        subst.
        rewrite_alist (nil ++ [(X0, bind_sub)] ++ E1 ++ E2).
        apply Sub_replacing...
        apply Sub_permutation...
        constructor...
        constructor...
      *
        rewrite subst_tt_intro with (X:=X)...
        remember (subst_tt X X0 (open_tt D X)).
        rewrite subst_tt_intro with (X:=X)...
        subst.
        rewrite_alist (nil ++ [(X0, bind_sub)] ++ E1 ++ E2).
        apply Sub_replacing...
        apply Sub_permutation...
        constructor...
        constructor...
      *
        rewrite subst_tt_intro with (X:=Y)...
        remember (subst_tt Y X0 (open_tt C Y)).
        rewrite subst_tt_intro with (X:=Y)...
        subst.
        rewrite_alist (nil ++ [(X0, bind_sub)] ++ E1 ++ E2).
        apply Sub_replacing...
        apply Sub_permutation...
        constructor...
        constructor...
      *
        rewrite_alist (nil ++ E1 ++ [(Y, bind_sub)] ++ E2).
        apply WFS_permutation...
      *
        rewrite_alist (nil ++ E1 ++ [(Y, bind_sub)] ++ E2).
        apply WFS_permutation...
      *
        apply wf_env_weakening...
      *
        destruct n...
    +
      constructor...
      dependent destruction H0...
      analyze_binds H0...
  -
    constructor...
    apply subst_tt_wfs3...
    destruct m;simpl;get_well_form...
    destruct m;simpl...
  -
    dependent destruction H4.
    simpl in *.
    constructor...
    rewrite choose_flip.
    remember (typ_mu (choose (flip m) C D)).
    rewrite choose_flip.
    subst.
    apply IHSub1...
    rewrite <- choose_flip.
    rewrite <- choose_flip...
  -
    dependent destruction H6.
    assert (type (typ_mu C)) by (get_well_form;apply WFS_type with (E:=(E1++E2));auto).
    assert (type (typ_mu D)) by (get_well_form;apply WFS_type with (E:=(E1++E2));auto).
    dependent destruction H9.
    dependent destruction H10.
    apply S_rec with (L:=L \u L0  \u {{X}} \u L1 \u L2 \u fv_tt C \u fv_tt D  \u dom E1 \u dom E2);intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_alist (nil ++ [(X0, bind_sub)] ++ (E1 ++ E2)).
      apply subst_tt_wfs3...
      apply WFS_permutation...
      rewrite_alist ([(X0, bind_sub)] ++ [(X, bind_sub)] ++ E1 ++ E2).
      apply WFS_permutation...
      apply WFS_weakening...
      destruct m;simpl;get_well_form...
      simpl;destruct m...
      destruct m;get_well_form;apply WFS_type with (E:=(E1++E2))...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_alist (nil ++ [(X0, bind_sub)] ++ (E1 ++ E2)).
      apply subst_tt_wfs3...
      apply WFS_permutation...
      rewrite_alist ([(X0, bind_sub)] ++ [(X, bind_sub)] ++ E1 ++ E2).
      apply WFS_permutation...
      apply WFS_weakening...
      destruct m;simpl;get_well_form...
      simpl;destruct m...
      destruct m;get_well_form;apply WFS_type with (E:=(E1++E2))...
    +
      rewrite <- mu_transform_1...
      rewrite <- mu_transform_1...
      rename X0 into Y.
      rewrite_alist (([(Y, bind_sub)] ++ E1) ++ E2).
      apply H2...
      *
        apply notin_union.
        split...
        apply notin_union.
        split...
        apply notin_union.
        split.
        apply notin_fl_tt_open...
        simpl.
        apply notin_union.
        split...
        apply notin_fl_tt_open...
        apply notin_union.
        split...
        apply notin_fl_tt_open...
        simpl.
        apply notin_union.
        split...
        apply notin_fl_tt_open...
      *
        rewrite_alist (nil ++ (Y~ bind_sub) ++ E1 ++ E2).
        apply Sub_weakening...
        constructor...
      *
        constructor...
      *
        rewrite <- mu_transform_2...
        rewrite <- mu_transform_2...
        apply H8...
        destruct m;simpl;constructor...
        rewrite subst_tt_intro with (X:=Y)...
        apply subst_tt_type...
        rewrite subst_tt_intro with (X:=Y)...
        apply subst_tt_type...
        destruct m;simpl;constructor...
        rewrite subst_tt_intro with (X:=Y)...
        apply subst_tt_type...
        rewrite subst_tt_intro with (X:=Y)...
        apply subst_tt_type...
      *
        destruct m;get_well_form;apply WFS_type with (E:=E1++E2)...
      *
        destruct m;get_well_form;apply WFS_type with (E:=E1++E2)...
  -
    dependent destruction H1.
    constructor...
    simpl in *.
    apply IHSub...
Qed.

Lemma unfolding_lemma: forall E A B,
    Sub E (typ_mu A) (typ_mu B) ->
    Sub E (open_tt A (typ_mu A)) (open_tt B (typ_mu B)).
Proof with auto.
  intros.
  assert (Hq:=H).
  dependent destruction H.
  pick fresh X.
  specialize_x_and_L X L.
  assert (Ht:=H1).
  rewrite_alist (nil ++ X~bind_sub ++E) in Ht.
  apply Sub_twice_to_one in Ht...
  apply sub_generalize_intensive with (C:=A) (D:=B) (m:=Pos) in Ht...
  -
    simpl in *...
    rewrite <- subst_tt_intro in Ht...
    rewrite <- subst_tt_intro in Ht...
  -
    apply notin_union.
    split...
    apply notin_union.
    split...
    apply notin_union.
    split.
    apply notin_fl_tt_open...
    apply notin_union.
    split...
    apply notin_fl_tt_open...
  -
    simpl in *...
    rewrite <- subst_tt_intro...
    rewrite <- subst_tt_intro...
  -
    get_well_form...
Qed.

End Nominal.

(* ========================================================== *)
(* ========================================================== *)
(* ========================================================== *)
(* ========================================================== *)
(* ========================================================== *)
(* ========================================================== *)
(* ========================================================== *)
(* ========================================================== *)
(* ========================================================== *)
(* ========================================================== *)
(* ========================================================== *)

Fixpoint upcast (A:typ) : Nominal.typ :=
  match A with
  | typ_nat => Nominal.typ_nat
  | typ_top => Nominal.typ_top
  | typ_fvar x => Nominal.typ_fvar x
  | typ_bvar b => Nominal.typ_bvar b
  | typ_arrow s t => Nominal.typ_arrow (upcast s) (upcast t)
  | typ_mu s => Nominal.typ_mu (upcast s)
  end.

Fixpoint upcast_env (E:env) : Nominal.env :=
  match E with
  | nil => nil
  | (x,bind_sub)::E' => (x,Nominal.bind_sub)::(upcast_env E')
  | (x,bind_typ _)::E' => (x,Nominal.bind_sub)::(upcast_env E')
  end.

Lemma notin_dom_upcast: forall E a,
     a `notin` dom E ->
     a `notin` dom (upcast_env E).
Proof with auto.
  induction E;intros...
  destruct a.
  simpl in *.
  destruct b...
Qed.

Lemma In_upcast:forall E X,
  In (X, bind_sub) E ->
     In (X, Nominal.bind_sub) (upcast_env E).
Proof with auto.
  induction E;intros...
  destruct a...
  simpl in *...
  destruct H...
  inversion H.
  apply in_eq...
  destruct b...
  apply in_cons...
  apply in_cons...
Qed.

Lemma upcast_open : forall A B,
    upcast (open_tt A B) = Nominal.open_tt (upcast A) (upcast B).
Proof with auto.
  intros.
  unfold open_tt.
  unfold Nominal.open_tt.
  generalize 0.
  generalize dependent B.
  induction A;intros;simpl;try solve [f_equal;auto]...
  -
    destruct (n0==n);simpl...
Qed.

Lemma upcast_open_var : forall A (X:atom),
    upcast (open_tt A X) = Nominal.open_tt (upcast A) (Nominal.typ_fvar X).
Proof with auto.
  intros.
  rewrite upcast_open...
Qed.

Lemma WF_upcast : forall E A,
    WF E A -> Nominal.WF (upcast_env E) (upcast A).
Proof with auto.
  intros.
  induction H;simpl in *...
  -
    constructor...
    unfold binds in *.
    apply In_upcast...
  -
    apply Nominal.WF_rec with (L:=L \u Nominal.fv_tt (upcast A));intros...
    specialize_x_and_L X L.
    rewrite upcast_open in H0...
Qed.

Lemma wf_env_upcast : forall E,
    wf_env E -> Nominal.wf_env (upcast_env E).
Proof with auto using notin_dom_upcast.
  intros.
  induction E;simpl...
  destruct a.
  dependent destruction H.
  constructor...
  constructor...
Qed.

Lemma double_unfolding_upcast : forall E A B,
    sub E A B -> Nominal.sub (upcast_env E) (upcast A) (upcast B).
Proof with auto using wf_env_upcast, WF_upcast.
  intros.
  induction H;simpl...
  -
    constructor...
    constructor...
    unfold binds in *.
    apply In_upcast...
  -
    apply Nominal.Sa_rec with (L:=L \u Nominal.fv_tt (upcast A1) \u Nominal.fv_tt (upcast A2));intros...
    +
      rewrite <- upcast_open_var...
      rewrite <- upcast_open_var...
      apply H0...
    +
      rewrite <- upcast_open_var...
      rewrite <- upcast_open_var...
      rewrite <- upcast_open...
      rewrite <- upcast_open...
      apply H2...
Qed.

Lemma double_to_nominal : forall E A B,
    sub E A B -> Nominal.Sub (upcast_env E) (upcast A) (upcast B).
Proof with auto.
  intros.
  apply double_unfolding_upcast in H.
  apply Nominal.sub_to_Sub...
Qed.

Fixpoint erase (A:Nominal.typ) : typ :=
  match A with
  | Nominal.typ_nat => typ_nat
  | Nominal.typ_top => typ_top
  | Nominal.typ_fvar x => typ_fvar x
  | Nominal.typ_bvar b => typ_bvar b
  | Nominal.typ_arrow s t => typ_arrow (erase s) (erase t)
  | Nominal.typ_mu s => typ_mu (erase s)
  | Nominal.typ_rcd l t => erase t
  end.

Fixpoint erase_env (E:Nominal.env) : env :=
  match E with
  | nil => nil
  | (x,Nominal.bind_sub)::E' => (x,bind_sub)::(erase_env E')
  end.

Lemma notin_dom_downcast: forall E a,
     a `notin` dom E ->
     a `notin` dom (erase_env E).
Proof with auto.
  induction E;intros...
  destruct a.
  simpl in *.
  destruct b...
Qed.

Lemma In_downcast:forall E X,
  In (X, Nominal.bind_sub) E ->
     In (X, bind_sub) (erase_env E).
Proof with auto.
  induction E;intros...
  destruct a...
  simpl in *...
  destruct H...
  inversion H.
  apply in_eq...
  destruct b...
  apply in_cons...
Qed.

Lemma downcast_open : forall A B,
    erase (Nominal.open_tt A B) = open_tt (erase A) (erase B).
Proof with auto.
  intros.
  unfold open_tt.
  unfold Nominal.open_tt.
  generalize 0.
  generalize dependent B.
  induction A;intros;simpl;try solve [f_equal;auto]...
  -
    destruct (n0==n);simpl...
Qed.

Lemma downcast_open_var : forall A (X:atom),
    erase (Nominal.open_tt A (Nominal.typ_fvar X)) = open_tt (erase A)  X.
Proof with auto.
  intros.
  rewrite downcast_open...
Qed.

Lemma WF_downcast : forall E A,
    Nominal.WF E A -> WF (erase_env E) (erase A).
Proof with auto.
  intros.
  induction H;simpl in *...
  -
    constructor...
    unfold binds in *.
    apply In_downcast...
  -
    apply WF_rec with (L:=L \u fv_tt (erase A));intros...
    specialize_x_and_L X L.
    rewrite downcast_open in H0...
    specialize_x_and_L X L.
    rewrite downcast_open in H0...
    rewrite subst_tt_intro with (X:=X)...
    apply subst_tt_wf...
Qed.

Lemma wf_env_downcast : forall E,
    Nominal.wf_env E -> wf_env (erase_env E).
Proof with auto using notin_dom_downcast.
  intros.
  induction E;simpl...
  destruct a.
  dependent destruction H.
  constructor...
Qed.

Lemma double_unfolding_downcast : forall E A B,
    Nominal.sub E A B -> sub (erase_env E) (erase A) (erase B).
Proof with auto using wf_env_downcast, WF_downcast.
  intros.
  induction H;simpl...
  -
    constructor...
    dependent destruction H0.
    unfold binds in *.
    apply In_downcast...
  -
    apply sa_rec with (L:=L \u fv_tt (erase A1) \u fv_tt (erase A2));intros...
    +
      rewrite <- downcast_open_var...
      rewrite <- downcast_open_var...
      apply H0...
    +
      rewrite <- downcast_open_var...
      rewrite <- downcast_open_var...
      rewrite <- downcast_open...
      rewrite <- downcast_open...
      apply H2...
Qed.

Lemma nominal_to_double: forall E A B,
    Nominal.Sub E A B -> sub (erase_env E) (erase A) (erase B).
Proof with auto.
  intros.
  apply double_unfolding_downcast...
  apply Nominal.Sub_to_sub...
Qed.

Corollary nominal_to_finite: forall E A B,
    Nominal.Sub E A B -> Sub (erase_env E) (erase A) (erase B).
Proof with auto.
  intros.
  apply soundness...
  apply nominal_to_double...
Qed.

Corollary finite_to_nominal : forall E A B,
    Sub E A B -> Nominal.Sub (upcast_env E) (upcast A) (upcast B).
Proof with auto.
  intros.
  apply double_to_nominal...
  apply completeness...
Qed.


Require Import Coq.Logic.Decidable.
Require Import PeanoNat.
Require Import Coq.Strings.String.
Require Import Ascii.
Require Import Bool.
Require Import Nat.

Require Import LIR.maps.
Require Import LIR.lir.
Require Import LIR.dyn.

Reserved Infix "<|" (at level 80).

(*
** Precision of types
*)
Inductive TPrecision : IRType -> IRType -> Prop :=
| PRTag : forall tg, Tag2Type tg <| Tag2Type tg
| TPStar : forall t, t <| IRTStar

  where "x '<|' y" := (TPrecision x y).

(*
** Type precision is reflexive
*)
Lemma TPrecisionRefl: forall t, t <| t.
Proof. destruct t; auto using TPrecision. Qed.

(*
** Type precision is transitive
*)
Lemma TPrecisionTrans: forall t1 t2 t3,
  t1 <| t2 -> t2 <| t3 -> t1 <| t3.
Proof.
  intros * H12 H23.
  destruct H12; auto using TPrecision.
  inversion H23; subst; auto using TPrecision.
Qed.

(*
** Type precision is assymetric
*)
Lemma TPrecisionAsym : forall t1 t2,
  t1 <| t2 -> t2 <| t1 -> t1 = t2.
Proof.
  intros * H12.
  destruct H12; intros H21; trivial; inversion H21; subst; auto.
Qed.

(*
** Ground types have nothing below them.
*)
Lemma GroundFlat : forall t g,
    t <| Tag2Type g -> t = Tag2Type g.
Proof.
  intros * H. inversion H; trivial.
Qed.

Ltac GroundFlat :=
  repeat match goal with [H: ?T1 <| Tag2Type ?T2 |- _] =>
    match goal with
    | [H: T1 = Tag2Type T2 |- _] => fail 1
    | [ |- _] => specialize (GroundFlat _ _ H) as ?
    end
  end.

Lemma GroundTop : forall t g1 g2,
  t <| Tag2Type g1 -> t <| Tag2Type g2 -> g1 = g2.
Proof.
  intros. GroundFlat. congruence.
Qed.

(*
** '*' is the largest type
*)
Lemma NoneBiggerThanStar : forall t, IRTStar <| t -> IRTStar = t.
Proof.
  destruct t; inversion 1; trivial.
Qed.

(*
** Lift type precision to optional types.
*)
Inductive TPrecOption : option IRType -> option IRType -> Prop :=
| TPrecN : TPrecOption None None
| TPrecS : forall t1 t2, t1 <| t2 -> TPrecOption (Some t1) (Some t2)
.

(*
** Environment precision
*)
Definition EnvComp (Γ1 Γ2 : IREnvironment) : Prop :=
    forall var, TPrecOption (In Γ1 var) (In Γ2 var).

Infix "<E|" := EnvComp (at level 70).

(*
** Environment precision is reflexive
*)
Lemma EnvCompRefl : forall Γ, Γ <E| Γ.
Proof.
  unfold EnvComp.
  intros.
  destruct (In Γ var); auto using TPrecOption, TPrecisionRefl.
Qed.

(* Nothing is smaller than the empty environment *)
Lemma EnvCompEmpty : forall Γ, Γ <E| MEmpty -> Γ = MEmpty.
Proof.
  intros [ | var ? ?] H; trivial.
  exfalso.
  specialize (H var).
  erewrite InEq in H.
  inversion H.
Qed.

(*
** Environment precision is transitive
*)
Lemma EnvCompTrans : forall Γ1 Γ2 Γ3,
    Γ1 <E| Γ2 -> Γ2 <E| Γ3 -> Γ1 <E| Γ3.
Proof.
  unfold EnvComp.
  intros * H12 H23 var.
  specialize (H12 var).
  specialize (H23 var).
  destruct (In Γ1 var);
  inversion H12; subst;
    match goal with
      [H: _ = In _ _ |- _] => rewrite <- H in *
    end;
  inversion H23; subst;
  eauto using TPrecOption, TPrecisionTrans.
Qed.

(*
** Extending environments preserve precision
*)
Lemma EnvCompExt : forall Γ1 Γ2 var t1 t2,
    Γ1 <E| Γ2 ->
    t1 <| t2 ->
    (var |=> t1; Γ1) <E| (var |=> t2; Γ2).
Proof.
  unfold EnvComp.
  intros.
  breakStrDec;
  auto using TPrecOption, TPrecisionRefl.
Qed.

Lemma PEnvIn : forall Γ1 Γ2 var t1 t2,
    Γ1 <E| Γ2 ->
    In Γ1 var = Some t1 ->
    In Γ2 var = Some t2 ->
    t1 <| t2.
Proof.
  intros * HP H1 H2.
  specialize (HP var).
  rewrite H1 in HP.
  rewrite H2 in HP.
  inversion HP. trivial.
Qed.

Lemma LELT : forall Γ1 Γ2 e t1 t2,
    Γ1 |= e : t1 ->
    Γ2 |= e : t2 ->
    Γ1 <E| Γ2 ->
    t1 <| t2.
Proof.
  intros * HT1.
  generalize dependent Γ2.
  induction HT1; inversion 1; subst;
    eauto using TPrecisionRefl, PEnvIn, EnvCompExt.
Qed.

(*
** The Precision relation for expressions
*)

(*
** (Precision Γ e1 τ1 Δ e2 τ2) means Γ⊑Δ ⊢ e1 ⊑ e2 : τ1 ⊑ τ2.
** In words: the expression e1 with type τ1 in the environment Γ is
** more (or equally) precise than the expression e2 with type τ2 in the
** environment Δ.
*)
Inductive Precision : IREnvironment -> IRE -> IRType ->
                      IREnvironment -> IRE -> IRType -> Prop :=

(*  Γ ⊑ Δ
   ----------------------
   Γ⊑ ⊢ nil ⊑ nil : nil ⊑ nil       *)
| PNil : forall Γ Δ, Γ <E| Δ -> Precision Γ IRENil IRTNil Δ IRENil IRTNil

(* Γ ⊑ Δ    (x : σ) ∈ Γ   (x : τ) ∈ Δ
  -----------------------------------
  Γ ⊢ x : σ ⊑ Δ ⊢ x : τ	*)
| PVar : forall Γ Δ var t1 t2,
    Γ <E| Δ ->
    In Γ var = Some t1 ->
    In Δ var = Some t2 ->
    Precision Γ (IREVar var) t1 Δ (IREVar var) t2

(* Γ ⊑ Δ
   ----------------------
   Γ⊑ ⊢ n ⊑ n : int ⊑ int	*)
| PNum : forall Γ Δ n, Γ <E| Δ -> Precision Γ (IRENum n) IRTInt Δ (IRENum n) IRTInt

(* Γ⊑ ⊢ d₁ ⊑ e₁ : int ⊑ int   Γ⊑ ⊢ d₂ ⊑ e₂ : int ⊑ int
   ----------------------------------------------------
   Γ⊑ ⊢ d₁ + d₂ ⊑ e₁ + e₂ : int ⊑ int	*)
| PPlus : forall Γ Δ d1 e1 d2 e2,
    Precision Γ d1 IRTInt Δ e1 IRTInt ->
    Precision Γ d2 IRTInt Δ e2 IRTInt ->
    Precision Γ (IREPlus d1 d2) IRTInt Δ (IREPlus e1 e2) IRTInt

(* Γ ⊑ Δ
   ----------------------
   Γ⊑ ⊢ {} ⊑ {} : tbl ⊑ tbl	*)
| PNew : forall Γ Δ, Γ <E| Δ -> Precision Γ IRENew IRTTbl Δ IRENew IRTTbl

(* Γ ⊑ Δ
   ----------------------
   Γ⊑ ⊢ a ⊑ a : tbl ⊑ tbl	*)
| PTAddr : forall Γ Δ addr, Γ <E| Δ -> Precision Γ (IRETAddr addr) IRTTbl
                                                 Δ (IRETAddr addr) IRTTbl

(* ----------------------
   Γ⊑ ⊢ a ⊑ a : fun ⊑ fun	*)
| PFAddr : forall Γ Δ addr, Γ <E| Δ -> Precision Γ (IREFAddr addr) IRTFun
                                                 Δ (IREFAddr addr) IRTFun

(* Γ⊑ ⊢ d₁ ⊑ e₁ : tbl ⊑ tbl   Γ⊑ ⊢ d₂ ⊑ e₂ : * ⊑ *
   ----------------------------------------------------
   Γ⊑ ⊢ d₁[d₂] ⊑ e₁[e₂] : * ⊑ *	*)
| PGet : forall Γ Δ d1 d2 i1 i2,
    Precision Γ d1 IRTTbl Δ d2 IRTTbl ->
    Precision Γ i1 IRTStar Δ i2 IRTStar ->
    Precision Γ (IREGet d1 i1) IRTStar Δ (IREGet d2 i2) IRTStar

| PSet : forall Γ Δ d1 d2 i1 i2 v1 v2,
    Precision Γ d1 IRTTbl Δ d2 IRTTbl ->
    Precision Γ i1 IRTStar Δ i2 IRTStar ->
    Precision Γ v1 IRTStar Δ v2 IRTStar ->
    Precision Γ (IRESet d1 i1 v1) IRTNil Δ (IRESet d2 i2 v2) IRTNil

(* Γ⊑, x : σ ⊑ τ ⊢ d₂ ⊑ e₂ : σ′ ⊑ τ′    Γ⊑ ⊢ d₁ ⊑ e₁ : σ ⊑ τ
   -------------------------------------------------------
   Γ⊑ ⊢ let x:σ = d₁ in d₂ ⊑ let x:τ = e₁ in e₂ : σ′ ⊑ τ′	*)
| PLet : forall Γ Δ var d1 t1 d2 t2 b1 t1' b2 t2',
    Precision (var |=> t1; Γ) b1 t1' (var |=> t2; Δ) b2 t2' ->
    Precision Γ d1 t1 Δ d2 t2 ->
    Precision Γ (IRELet var t1 d1 b1) t1' Δ (IRELet var t2 d2 b2) t2'

(* Γ⊑, x : * ⊑ * ⊢ d ⊑ e : * ⊑ *
   --------------------------------
   Γ⊑ ⊢ (λx.d) ⊑ (λx.e) : fun ⊑ fun	*)
| PFun : forall Γ Δ var d1 d2,
    Precision (var |=> IRTStar; Γ) d1 IRTStar (var |=> IRTStar; Δ) d2 IRTStar ->
    Γ <E| Δ ->
    Precision Γ (IREFun var d1) IRTFun Δ (IREFun var d2) IRTFun

(* Γ⊑ ⊢ d₁ ⊑ e₁ : fun ⊑ fun    Γ⊑ ⊢ d₂ ⊑ e₂ : * ⊑ *
  -------------------------------------------------
  Γ⊑ ⊢ d₁(d₂) ⊑ e₁(e₂) : * ⊑ *	*)
| PApp : forall Γ Δ f1 v1 f2 v2,
    Precision Γ v1 IRTStar Δ v2 IRTStar ->
    Precision Γ f1 IRTFun Δ f2 IRTFun ->
    Precision Γ (IREApp f1 v1) IRTStar Δ (IREApp f2 v2) IRTStar

(* Γ⊑ ⊢ d ⊑ e : t ⊑ g
   ----------------------------------
   Γ⊑ ⊢ d ⊑ box[g](e) : t ⊑ ★	*)
(* Note: in our particular case, t must be equal to g, because
   g is a ground type and there is no type strictly more precise
   than a ground type. *)
| PBoxR : forall Γ Δ d e t g,
    Precision Γ d t Δ e (Tag2Type g) ->
    Precision Γ d t Δ (IREBox g e) IRTStar

(* Γ⊑ ⊢ d ⊑ e : g ⊑ ★
   ----------------------------------
   Γ⊑ ⊢ box[g]d ⊑ e : ★ ⊑ ★	*)
| PBoxL : forall Γ Δ d e g,
    Precision Γ d (Tag2Type g) Δ e IRTStar ->
    Precision Γ (IREBox g d) IRTStar Δ e IRTStar

(* Γ⊑ ⊢ d ⊑ e : ★ ⊑ ★
   ----------------------------------
   Γ⊑ ⊢ unbox[g](d) ⊑ e : g ⊑ *		*)
| PUnboxL : forall Γ Δ d e g tg,
    tg = Tag2Type g ->
    Precision Γ d IRTStar Δ e IRTStar ->
    Precision Γ (IREUnbox g d) tg Δ e IRTStar

(* Γ⊑ ⊢ d ⊑ e : t ⊑ ★ , t ⊑ g
   ----------------------------------
   Γ⊑ ⊢ d ⊑ unbox[g](e) : t ⊑ g	*)
| PUnboxR : forall Γ Δ d e t g tg,
    t <| (Tag2Type g) ->
    tg = Tag2Type g ->
    Precision Γ d t Δ e IRTStar ->
    Precision Γ d t Δ (IREUnbox g e) tg

.

(* Γ⊑ ⊢ d ⊑ e : g ⊑ g
   ----------------------------------
   Γ⊑ ⊢ box[g](d) ⊑ box[g](e) : ★ ⊑ ★	*)
Lemma BoxCongruent : forall Γ Δ d e g,
    Precision Γ d (Tag2Type g) Δ e (Tag2Type g) ->
    Precision Γ (IREBox g d) IRTStar Δ (IREBox g e) IRTStar.
Proof. eauto using Precision. Qed.

(* Γ⊑ ⊢ d ⊑ e : ★ ⊑ ★
   ----------------------------------
   Γ⊑ ⊢ unbox[g](d) ⊑ unbox[g](e) : g ⊑ g	*)
Lemma UnboxCongruent: forall Γ Δ d e g,
    Precision Γ d IRTStar Δ e IRTStar ->
    Precision Γ (IREUnbox g d) (Tag2Type g) Δ (IREUnbox g e) (Tag2Type g).
Proof. eauto using Precision, TPrecisionRefl. Qed.

(* Strip an expression of all its boxes and unboxes *)
Fixpoint Tbones (e : IRE) : IRE :=
  match e with
  | IRENil => e
  | IRENum n => e
  | IREPlus e1 e2 => IREPlus (Tbones e1) (Tbones e2)
  | IRENew => e
  | IRETAddr a => e
  | IREFAddr b => e
  | IREGet t i => IREGet (Tbones t) (Tbones i)
  | IRESet t i v => IRESet (Tbones t) (Tbones i) (Tbones v)
  | IREVar v => e
  | IRELet v t e1 e2 => IRELet v IRTStar (Tbones e1) (Tbones e2)
  | IREFun v b => IREFun v (Tbones b)
  | IREApp e1 e2 => IREApp (Tbones e1) (Tbones e2)
  | IREBox t e => Tbones e
  | IREUnbox t e => Tbones e
  end.

(* Equal bones is the same as equal 'dyn' *)
Lemma DynBones : forall e1 e2, dyn e1 = dyn e2 <-> Tbones e1 = Tbones e2.
Proof.
  split; generalize dependent e2; induction e1; intros * H;
  induction e2;
  try (discriminate H);  (* eliminate cases with different structures *)
  try (injection H; intros; subst);  (* extract equality of fields *)
  eauto;  (* solve cases that don't need 'f_equal' *)
  simpl;
  (* break equalities up to 'dyn' or 'Tbones' *)
  repeat match goal with
    |[ |- dyn _ = dyn _] => idtac  (* ignore *)
    |[ |- Tbones _ = Tbones _] => idtac  (* ignore *)
    |[ |- _ _ = _ _] => f_equal  (* apply f_equal to all other equalities *)
  end;
  eauto.  (* solve the subcases *)
Qed.

(* Expressions related by Precision differ only in boxes and unboxes *)
Lemma EqBones : forall Γ Δ e1 t1 e2 t2,
  Precision Γ e1 t1 Δ e2 t2 -> Tbones e1 = Tbones e2.
Proof.
  induction 1; trivial; simpl; congruence.
Qed.

Module Examples.

Definition B10 := (IREBox TgInt (IRENum 10)).

Definition UB10 := IREUnbox TgInt B10.

(* 10 ⊑ unbox[int](box[int](10)) : int ⊑ int *)
Example example1 : Precision MEmpty (IRENum 10) IRTInt MEmpty UB10 IRTInt.
  eauto using Precision, TPrecisionRefl, EnvCompRefl.
Qed.

(* FALSE!  unbox[int](box[int](10)) ⊑ 10 : int ⊑ int *)
Example example2 : ~ Precision MEmpty UB10 IRTInt MEmpty (IRENum 10) IRTInt.
  inversion 1.
Qed.

(* unbox[int](box[int](10)) ⊑ box[int](10) : int ⊑ * *)
Example example3 : Precision MEmpty UB10 IRTInt MEmpty B10 IRTStar.
  eauto using Precision, EnvCompRefl.
Qed.

(*
  let x : int = 10 in x + 1
  let x : * = box 10 in unbox x + 1
*)
Definition X := "x":string.

Goal Precision MEmpty
  (IRELet X IRTInt (IRENum 10)
     (IREPlus (IREVar X) (IRENum 1)))  IRTInt
    MEmpty
  (IRELet X IRTStar (IREBox TgInt(IRENum 10))
     (IREPlus (IREUnbox TgInt (IREVar X)) (IRENum 1))) IRTInt.
Proof.
  unfold IRTInt.
  eapply PLet.
  - eapply PPlus;
    eauto using Precision, TPrecision, EnvCompRefl, EnvCompExt.
  - eauto using Precision, EnvCompRefl.
Qed.

(* Nothing is smaller than 10 *)
Goal forall E T,
  Precision MEmpty E T MEmpty (IRENum 10) IRTInt ->
  E = IRENum 10.
Proof.
  induction E; inversion 1; subst; trivial.
Qed.

(* Precision does not preserve values in any direction *)

Goal exists e1 t1 e2 t2,
    Precision MEmpty e1 t1 MEmpty e2 t2 /\ Value e1 /\ ~Value e2.
  eexists; eexists; eexists; eexists.
  repeat split.
  - apply example1.
  - eauto using Value.
  - intros Hcontra. inversion Hcontra.
Qed.

Goal exists e1 t1 e2 t2,
    Precision MEmpty e1 t1 MEmpty e2 t2 /\ Value e2 /\ ~Value e1.
  eexists; eexists; eexists; eexists.
  repeat split.
  - apply example3.
  - eauto using Value.
  - inversion 1.
Qed.

(* Types inside precision-related expressions can go astray... *)
Goal Precision MEmpty (IREBox TgTbl (IREUnbox TgTbl B10)) IRTStar MEmpty B10 IRTStar.
Proof.
  eauto 6 using Precision, EnvCompRefl.
Qed.

(*
** ... which breaks some nice properties: although B10 is a maximum
** for 10 (everything larger than 10 is smaller than B10), 10 is not
** a minimum for B10...
*)
Goal ~ Precision MEmpty (IRENum 10) IRTInt
                 MEmpty (IREBox TgTbl (IREUnbox TgTbl B10)) IRTStar.
Proof.
  intro.
  repeat match goal with
  |[H: Precision _ _ _ _ _ _ |- _] => inversion H; subst; clear H
  |[H: _ <| Tag2Type _ |- _] => inversion H; subst; clear H
  end.
Qed.

(* a[10] *)
Definition get10 (a : nat) := IREGet (IRETAddr a) B10.

(* unbox[int](a[10]) ⊑ a[10] *)
Goal forall a,
    Precision MEmpty (IREUnbox TgInt (get10 a)) (Tag2Type TgInt)
              MEmpty (get10 a) IRTStar.
Proof.
  eauto 7 using Precision, EnvCompRefl.
Qed.

(* box[int](unbox[int](a[10])) ⊑ a[10] *)
Goal forall a, Precision
                 MEmpty (IREBox TgInt (IREUnbox TgInt (get10 a))) IRTStar
                 MEmpty (get10 a) IRTStar.
Proof.
  eauto 8 using Precision, EnvCompRefl.
Qed.

(* ~ a[10] ⊑ box[int](unbox[int](a[10])) *)
Goal forall a, ~ Precision
                   MEmpty (get10 a) IRTStar
                   MEmpty (IREBox TgInt (IREUnbox TgInt (get10 a))) IRTStar.
Proof.
  intros * ?.
  repeat match goal with
  |[H: Precision _ _ _ _ _ _ |- _] => inversion H; subst; clear H
  |[H: _ <| Tag2Type _ |- _] => inversion H; subst; clear H
  end.
Qed.

(*
** Next two examples show that Precision is not a proper order,
** but a preorder.
*)
Definition BUB10 := IREBox TgInt UB10.

(* box[int](unbox[int](box[int](10))) ⊑ box[int](10) : * ⊑ * *)
Example e6 : Precision MEmpty BUB10 IRTStar MEmpty B10 IRTStar.
  eauto 6 using Precision, EnvCompRefl.
Qed.

(* box[int](10) ⊑ box[int](unbox[int](box[int](10))) : * ⊑ * *)
Example e7 : Precision MEmpty B10 IRTStar MEmpty BUB10 IRTStar.
  eauto 6 using Precision, TPrecisionRefl, EnvCompRefl.
Qed.

End Examples.

(* For precision environments, equivalence implies inclusion *)
Lemma PinclusionEquiv : forall (Γ Γ' : IREnvironment),
    map_eq Γ Γ' -> inclusion Γ Γ'.
Proof.
  intuition congruence.
Qed.

(*
** The environments in a precision relation must be
** in a precision relation too.
*)
Lemma PPE : forall Γ Δ e1 t1 e2 t2,
    Precision Γ e1 t1 Δ e2 t2 -> Γ <E| Δ.
Proof.
  induction 1; eauto using TPrecision, TPrecisionRefl, PEnvIn.
Qed.

(*
** The types in a precision relation must be
** in a precision relation too.
*)
Lemma PPT : forall Γ Δ e1 t1 e2 t2,
    Precision Γ e1 t1 Δ e2 t2 -> t1 <| t2.
Proof.
  induction 1; subst; eauto using TPrecision, TPrecisionRefl, PEnvIn.
Qed.

Lemma extend2Types : forall Γ Δ var t1 t1' t2 t2' b1 b2,
    Precision (var |=> t1; Γ) b1 t1' (var |=> t2; Δ) b2 t2' ->
    t1 <| t2.
Proof.
  intros * HP.
  apply PPE in HP.
  specialize (HP var).
  rewrite InEq in HP.
  rewrite InEq in HP.
  inversion HP.
  trivial.
Qed.

Lemma PrecisionInclusion : forall Γ1 Γ2 Δ1 Δ2 e1 t1 e2 t2,
    Precision Γ1 e1 t1 Δ1 e2 t2 ->
    inclusion Γ1 Γ2 ->
    inclusion Δ1 Δ2 ->
    Γ2 <E| Δ2 ->
    Precision Γ2 e1 t1 Δ2 e2 t2.
Proof.
  intros * HP.
  generalize dependent Γ2.
  generalize dependent Δ2.
  induction HP;
    eauto 8 using Precision, inclusion_update, EnvCompExt, PPT.
Qed.

Lemma PrecisionInclusionE : forall Γ Δ e1 t1 e2 t2,
    Precision MEmpty e1 t1 MEmpty e2 t2 ->
    Γ <E| Δ ->
    Precision Γ e1 t1 Δ e2 t2.
Proof.
  intros; eauto using PrecisionInclusion, inclusion_empty.
Qed.

(*
** Precision subsumes typing for its first expression
*)
Lemma PrecisionType1: forall Γ Δ e1 t1 e2 t2,
  Precision Γ e1 t1 Δ e2 t2 -> Γ |= e1 : t1.
Proof.
  induction 1; eauto using IRTyping.
Qed.

(*
** Precision subsumes typing for its second expression
*)
Lemma PrecisionType2: forall Γ Δ e1 t1 e2 t2,
  Precision Γ e1 t1 Δ e2 t2 -> Δ |= e2 : t2.
Proof.
  induction 1; eauto using IRTyping.
Qed.

(*
** Precision is relfexive for well-typed terms
*)
Lemma PrecisionRefl: forall Γ e t,
    Γ |= e : t ->  Precision Γ e t Γ e t.
Proof.
  induction 1; subst; eauto using Precision, UnboxCongruent, EnvCompRefl.
Qed.

Lemma PEnvDyn : forall Γ, Γ <E| dynGamma Γ.
Proof.
  intros Γ var.
  destruct (In Γ var) eqn:?.
  - rewrite TP2TGammaIn with (T := i); auto using TPrecOption, TPrecision.
  - rewrite NTP2TGammaIn; auto using TPrecOption.
Qed.

(*
** Type erasure produces expresssions that are less precise than
** the original
*)
Theorem DynLessPrecise : forall Γ e t,
  Γ |= e : t -> Precision Γ e t (dynGamma Γ) (dyn e) IRTStar.
Proof.
  induction 1; simpl; eauto using Precision, TPrecision, TP2TGammaIn, PEnvDyn.
Qed.

(*
** Any pair of expressions in a precision relation are equal
** up to type erasure.
*)
Theorem PrecDynEqual : forall Γ Δ e1 t1 e2 t2,
    Precision Γ e1 t1 Δ e2 t2 -> dyn e2 = dyn e1.
Proof.
  induction 1; simpl; congruence.
Qed.

(*
** Any star value less precise than an expression is equal to the
** expression type erasure.
*)
Theorem PrecDynEqualVal : forall e1 t1 e2,
    Value e2 ->
    Precision MEmpty e1 t1 MEmpty e2 IRTStar ->
    e2 = dyn e1.
Proof.
  intros.
  replace e2 with (dyn e2);
  eauto using PrecDynEqual, PrecisionType2, ValueStar, eq_sym.
Qed.

(*
** (dyn e1) is larger than any expression larger than e1:
** forall e2, e1 ⊑ e2  ->  e2 ⊑ dyn (e1)
*)
Theorem DynMoreDyn : forall Γ Δ e1 t1 e2 t2,
  Precision Γ e1 t1 Δ e2 t2 ->
  Precision Δ e2 t2 (dynGamma Δ) (dyn e1) IRTStar.
Proof.
  intros.
  replace (dyn e1) with (dyn e2) by eauto using PrecDynEqual.
  eauto using DynLessPrecise, PrecisionType2.
Qed.

Lemma PrecEnvL1 : forall Γ1 Γ1' Γ2 e1 e2 t1 t1' t2,
    Precision Γ1 e1 t1 Γ2 e2 t2 ->
    Γ1' <E| Γ1 ->
    Γ1' |= e1 : t1' ->
    Precision Γ1' e1 t1' Γ2 e2 t2.
Proof.
  intros * HP1.
  generalize dependent t1'.
  generalize dependent Γ1'.
  induction HP1; intros * HPE HT; GroundFlat;
    inversion HT; subst;
    eauto using Precision, EnvCompTrans, EnvCompExt, TPrecisionRefl,
                LELT, PrecisionType1.
Qed.

Lemma PrecEnvL2 : forall Γ1 Γ2 Γ2' e1 e2 t1 t2 t2',
    Precision Γ1 e1 t1 Γ2 e2 t2 ->
    Γ2 <E| Γ2' ->
    Γ2' |= e2 : t2' ->
    Precision Γ1 e1 t1 Γ2' e2 t2'.
Proof.
  intros * HP1.
  generalize dependent t2'.
  generalize dependent Γ2'.
  induction HP1; intros * HPE HT;

  (* Get cases when t2' must be '*' *)
  try match goal with
  [H1: Precision _ _ _ ?E1 ?e IRTStar,
   H2: ?E2 |= ?e : ?T,
   H3: ?E1 <E| ?E2 |- _] =>
     assert (IRTStar = T) by
       (eauto using NoneBiggerThanStar, LELT, PrecisionType2);
     subst
  end;

  inversion HT; subst;
    eauto using Precision, EnvCompTrans, EnvCompExt, TPrecisionRefl.
Qed.

(*
** For 'PrecTrans': generalize the term in the second Precision hypothesis
** and does an induction in that Precision.
*)
Ltac ind2 Γ3 e3 t3 :=
  match goal with
    |[H: Precision _ ?E _ Γ3 e3 t3 |- _] =>
      remember E as E' eqn:Heq;
      induction H; intros; GroundFlat; inversion Heq; subst;
      eauto using Precision, EnvCompTrans, PPT
  end.

(*
** A few cases need only this change of type to succeed.
*)
Ltac changeT T :=
  match goal with
    |[H: Precision _ _ IRTStar _ _ T |- _] =>
       replace T with IRTStar in * by (eauto using NoneBiggerThanStar, PPT);
       eauto using Precision
  end.

Ltac NoneBiggerThanStar :=
  try match goal with
    |[H: Precision _ _ IRTStar _ _ (Tag2Type _) |- _] => apply PPT in H
  end;
  try match goal with
    |[H: IRTStar <| Tag2Type _ |- _] => apply NoneBiggerThanStar in H; discriminate
   end.

Lemma PrecTrans : forall e2 Γ1 Γ2 Γ3 e1 e3 t1 t2 t3,
    Precision Γ1 e1 t1 Γ2 e2 t2 ->
    Precision Γ2 e2 t2 Γ3 e3 t3 ->
    Precision Γ1 e1 t1 Γ3 e3 t3.
Proof.

  intros * HP1.
  generalize dependent t3.
  generalize dependent e3.
  generalize dependent Γ3.
  induction HP1; intros * HP2;
    GroundFlat; subst;

    try (changeT t3);

    (* most cases can be solved by inversion on HP2 *)
    try (inversion HP2; subst;
         eauto using Precision, EnvCompTrans, PrecEnvL1, IRTyping;
         NoneBiggerThanStar;
         fail);

    (* some cases need induction on HP2 *)
    ind2 Γ3 e3 t3.

Qed.


Require Export A1_Plan.

Section CLOCKWISE.

Parameter Clockwise : Point -> Point -> Point -> Prop.

Definition HalfPlane (A B : Point) : Figure := Clockwise A B.

Definition EquiOriented (A B C D: Point) : Prop  :=
	SubFigure (HalfPlane A B) (HalfPlane C D).

Definition EquiDirected := fun A B C D : Point =>
	EquiOriented A B C D \/ EquiOriented A B D C \/
	EquiOriented B A C D \/ EquiOriented B A D C \/
	EquiOriented C D A B \/ EquiOriented C D B A \/
	EquiOriented D C A B \/ EquiOriented D C B A.

Definition HalfLine (A B : Point) : Figure  :=
	fun C : Point => EquiOriented A B A C.

Definition Collinear (A B C : Point) := ~Clockwise A B C /\ ~Clockwise B A C.

Definition Between (A B C : Point) :=
	A <> B /\ EquiOriented A B B C.

Axiom ClockwiseAntisym : forall A B C, ~Clockwise A B C \/ ~Clockwise B A C.

Axiom ClockwisePerm : forall A B C, Clockwise A B C -> Clockwise B C A.

Axiom FourCases : forall A B C,
	Clockwise A B C \/ Clockwise B A C \/ HalfLine A B C \/ HalfLine B A C.

Axiom FourthPoint : forall A B C D,
	Clockwise A B C ->
	Clockwise A B D \/ Clockwise A D C \/ Clockwise D B C.

Axiom ChangeSense : forall A B C,
	EquiOriented A B A C ->
	EquiOriented B A C A.

Axiom ChangeSide : forall A B C D,
	EquiOriented A B C D ->
	A <> B ->
	EquiOriented D C B A.

End CLOCKWISE.

Ltac simplClockwise :=
	unfold Between, EquiDirected, HalfLine, EquiOriented, HalfPlane, SubFigure, Included, In, Collinear in *.

Ltac canonize :=
	simplClockwise; dintuition.

Ltac writeChangeSense :=
	match goal with
		| H: forall E : Point, Clockwise ?A ?B E -> Clockwise ?A ?C E |- _ =>
			generalize (ChangeSense A B C H); generalize H; clear H; writeChangeSense
		| _ => idtac
	end.

Ltac generalizeChangeSense :=
	canonize; writeChangeSense; canonize.

Ltac writeChangeSide :=
	match goal with
		| H: forall E : Point, Clockwise ?A ?B E -> Clockwise ?C ?D E |- _ =>
			generalize (ChangeSide A B C D H); generalize H; clear H; writeChangeSide
		| _ => idtac
	end.

Ltac generalizeChangeSide :=
	canonize; writeChangeSide; canonize.

Ltac generalizeChange :=
	canonize; writeChangeSense; simplClockwise; intros; writeChangeSide; canonize.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Import UsefulTypes.

Definition bin_rel (T : Type) := T -> T -> [univ].

Definition trans_rel {T} (R : bin_rel T) :=
  forall x y z, R x y -> R y z -> R x z.

Definition symm_rel {T} (R : bin_rel T) :=
  forall x y, R x y -> R y x.

Definition refl_rel {T} (R : bin_rel T) :=
  forall x, R x x.

(** defines when a binary relation is Less or Equal*)
Definition le_bin_rel {T:Type} (R1 R2: @bin_rel T) : [univ] :=
  forall (a b : T), R1 a b -> R2 a b.

Definition eq_bin_rel {T} (R1 R2 : bin_rel T) :=
  le_bin_rel R1 R2 # le_bin_rel R2 R1.

Definition is_ge_any_rel_sat {T:[univ]} (R: @bin_rel T)
   (C: (@bin_rel T)->[univ]) : [univ] :=
  forall (Rp: @bin_rel T), C Rp -> le_bin_rel Rp R.

Definition is_greatest_rel_sat {T:[univ]} (R: @bin_rel T)
           (C: (@bin_rel T)->[univ]) : [univ] :=
  C R # is_ge_any_rel_sat R C.

Definition bin_rel_and {T} (R1 R2:bin_rel T ):=
  fun x y => R1 x y # R2 x y.

Definition  indep_bin_rel {T:Type} (Rl Rr: T -> [univ]) : ( @bin_rel T)
  := fun x y => (Rl x # Rr y).

Lemma lift_bin_rel_if : forall {T:[univ]} (R : bin_rel T) (b:bool)
     nl1 nl2 nr1 nr2,
  R nl1 nr1
  -> R nl2 nr2
  -> R (if b then nl1 else nl2) (if b then nr1 else nr2).
Proof.
  intros. cases_if; sp.
Qed.

(* do not change the Prop in Pl Pr. they will be used for things
    of standard library in prop*)
Lemma lift_bin_rel_ifdp : forall {T:[univ]} {Pl Pr : Prop} (R : bin_rel T)
    (b: (@sumbool Pl  Pr))
     nl1 nl2 nr1 nr2,
  R nl1 nr1
  -> R nl2 nr2
  -> R (if b then nl1 else nl2) (if b then nr1 else nr2).
Proof.
  intros. cases_if; sp.
Qed.


(* $Id: CMonoids.v,v 1.8 2003/03/11 13:35:51 lcf Exp $ *)

Require Export CSemiGroups.

(* Begin_SpecReals *)

(* Tex_Prose
\chapter{Monoids}\label{section:monoids}
We deal only with commutative algebraic structures.
*)

(* Tex_Prose
\section{Definition of monoids}
*)

(* Begin_Tex_Verb *)
Definition is_rht_unit
 [S: CSetoid; op: (CSetoid_bin_op S); one: S] : Prop :=
    (x: S)((op x one) [=] x).
(* End_Tex_Verb *)

(* End_SpecReals *)

(* Begin_Tex_Verb *)
Definition is_lft_unit
 [S: CSetoid; op: (CSetoid_bin_op S); one: S] : Prop :=
    (x: S)((op one x) [=] x).
(* End_Tex_Verb *)

Implicits is_lft_unit [1].

(* Begin_SpecReals *)

Implicits is_rht_unit [1].

(* Begin_Tex_Verb *)
Record is_CMonoid [M: CSemi_grp]: CProp :=
  { runit : (is_rht_unit (!csg_op M) Zero);
    commut: (commutes (!csg_op M))
  }.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Record CMonoid : Type :=
  { cm_crr   :> CSemi_grp;
    cm_proof :  (is_CMonoid cm_crr)
  }.
(* End_Tex_Verb *)
(* End_SpecReals *)

(* Tex_Prose
\section{Monoid axioms}
\begin{convention}
Let \verb!M! be a monoid.
\end{convention}
*)
Section CMonoid_axioms.
Variable M : CMonoid.

(* Begin_Tex_Verb *)
Lemma CMonoid_is_CMonoid : (is_CMonoid M).
(* End_Tex_Verb *)
Elim M; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma cm_rht_unit: (is_rht_unit csg_op Zero::M).
(* End_Tex_Verb *)
Elim CMonoid_is_CMonoid; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma cm_commutes: (commutes (!csg_op M)).
(* End_Tex_Verb *)
Elim CMonoid_is_CMonoid; Auto.
Qed.

End CMonoid_axioms.

(* Tex_Prose
\section{Monoid basics}
\begin{convention}
Let \verb!M! be a monoid.
\end{convention}
*)
Section CMonoid_basics.
Variable M : CMonoid.

(* Begin_Tex_Verb *)
Lemma cm_commutes_unfolded: (x, y: M)((x [+] y) [=] (y [+] x)).
(* End_Tex_Verb *)
Proof (cm_commutes M).
Hints Resolve cm_commutes_unfolded : algebra.

(* Begin_Tex_Verb *)
Lemma cm_rht_unit_unfolded : (x:M)((x [+] Zero) [=] x).
(* End_Tex_Verb *)
Intro.
Apply (cm_rht_unit M).
Qed.

(* Begin_Tex_Verb *)
Lemma lftUnit_iff_rhtUnit:
  (x:M)(is_lft_unit csg_op x)<->(is_rht_unit csg_op x).
(* End_Tex_Verb *)
Proof.
Intro x; Split; Red; Intros H x0.
Step_final (x [+] x0).
Step_final (x0 [+] x).
Qed.

(* Begin_Tex_Verb *)
Lemma cm_lft_unit: (is_lft_unit csg_op Zero::M).
(* End_Tex_Verb *)
Generalize (lftUnit_iff_rhtUnit Zero); Intro H.
Elim H; Intros H0 H1.
Apply H1.
Apply cm_rht_unit.
Qed.

(* Begin_Tex_Verb *)
Lemma cm_lft_unit_unfolded: (x:M)((Zero [+] x) [=] x).
(* End_Tex_Verb *)
  Proof cm_lft_unit.

Hints Resolve cm_rht_unit_unfolded cm_lft_unit_unfolded : algebra.

(* Begin_Tex_Verb *)
Lemma cm_unit_unique_lft:
    (x:M)(is_lft_unit csg_op x)->(x [=] Zero).
(* End_Tex_Verb *)
Intros x h. Red in h.
Step_final (x [+] Zero).
Qed.

(* Begin_Tex_Verb *)
Lemma cm_unit_unique_rht:
    (x:M)(is_rht_unit csg_op x)->(x [=] Zero).
(* End_Tex_Verb *)
Intros x h. Red in h.
Step_final (Zero [+] x).
Qed.

(* Begin_SpecReals *)

(* Tex_Prose
The proof component of the monoid is irrelevant.
*)
(* Begin_Tex_Verb *)
Lemma is_CMonoid_proof_irr :
  (S:CSetoid)(one:S)(mult:(CSetoid_bin_op S))(p,q:(associative mult))
                 (is_CMonoid (Build_CSemi_grp S one mult p)) ->
                 (is_CMonoid (Build_CSemi_grp S one mult q)).
(* End_Tex_Verb *)
Intros S one mult p q H.
Elim H; Intros runit0 commut0.
Simpl in runit0.
Simpl in commut0.
Apply Build_is_CMonoid; Simpl; Assumption.
Qed.

(* End_SpecReals *)

(* Tex_Prose
\section{Submonoids}
\begin{convention}
Let \verb!P! a predicate on \verb!M! with
\verb!P Zero! and which is preserved by \verb![+]!.
\end{convention}
*)

Section SubCMonoids.
Variable P         : M -> CProp.
Variable Punit     : (P Zero).
Variable op_pres_P : (bin_op_pres_pred ? P csg_op).

(* Begin_Tex_Verb *)
Local subcrr : CSemi_grp := (Build_SubCSemi_grp ? ? Punit op_pres_P).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma ismon_scrr: (is_CMonoid subcrr).
(* End_Tex_Verb *)
Split; Red.

(* unit *)
Intro x. Case x. Intros scs_elem scs_prf.
Apply (cm_rht_unit_unfolded scs_elem).

(* commutes *)
Intros x y. Case y. Case x. Intros scs_elem scs_prf scs_elem0 scs_prf0.
Exact (cm_commutes_unfolded scs_elem scs_elem0).
Qed.

(* Begin_Tex_Verb *)
Definition Build_SubCMonoid : CMonoid := (Build_CMonoid subcrr ismon_scrr).
(* End_Tex_Verb *)

End SubCMonoids.

End CMonoid_basics.

Hints Resolve cm_rht_unit_unfolded cm_lft_unit_unfolded : algebra.
Hints Resolve cm_commutes_unfolded : algebra.


(**
スモール SSReflect の製作
======
2015/08/11

@suharahiromichi

# はじめに

命題(Prop型)をbool型の式に変換すること（とその逆）をリフレクションと呼びます。

例： ``x = y`` と ``x == y``

命題をbool型の計算に変換することで、命題の証明が簡単になる場合があります。
そのリフレクションを「狭い範囲」で行い、証明の効率化を図るのが、
CoqのSmall Scale Reflection (SSReflect) 拡張です。

今回は、SSReflectのしくみを理解することを目的に、
Starndard Coqをもとに「SSReflectもどき」を作り、
Leibniz同値関係とbool値等式のリフレクションができるまでを示します。

それを通して、
Coqのコアーション(coersion)や、カノニカル・ストラクチャ(Canonical Structure)の
説明もしたいと思います。

# 今回のソースの在処

- Markdown版は以下のソースから生成した。
``https://github.com/suharahiromichi/coq/tree/master/ssr/ssr_small_ssreflect.v``

- 以下の版で動作を確認した。SSReflectおよびMathCompは使わない。
``8.4pl2``

# 概要

1. bool型からProp型へのコアーション
2. Reflect補題の証明
3. eqTypeの定義と、eq_op (``==``) の定義
4. bool型の値を引数とする決定可能なbool値等式の定義と、Leibniz同値関係の等価性
5. nat型の値を引数とする決定可能なbool値等式の定義と、Leibniz同値関係の等価性
6. Viewとその補題の証明
7. Leibniz同値関係とbool値等式のリフレクション（x = y と x == y の相互変換）の例

# 説明

## 準備
*)
Set Implicit Arguments.
Unset Strict Implicit.

Unset Printing Implicit Defensive.
Set Print All.
(* Set Printing Coercions. *)

(**
最初のふたつで引数の一部を省略できるようになる。
ただし、今回はこの設定の有無が影響しないように
関数等の``()``、``{}``や``@``を適切に使い分けている。
（``{}``は省略できる引数、``@``はそれを省略せず指定することを意味する）

``Set Printing Coercions`` は、コアーションを省略せずに表示するもの
であるが、``*goals*``や``*response*``バッファ にしか影響しない。
*)

(**
## bool型からProp型（命題型）へのコアーション

bool型からProp型に変換する関数を定義する。
 *)
Definition is_true (x : bool) : Prop := x = true.
Check is_true : bool -> Prop.
Check true : bool.
Check is_true true : Prop.

(**
bool型の値をProp型の値として扱えるようにする（埋め込むともいう）。
これは、``is_true : bool -> Prop`` という関数を、表記上、省略することで実現する。
*)

Fail Check true : Prop.                     (* まだ、is_trueは省けない。 *)
(**
bool型からProp型へのコアーションを宣言する。
 *)
Coercion is_true : bool >-> Sortclass.      (* コアーションの宣言 *)
Print Graph.                                (* [is_true] : bool >-> Sortclass *)
(**
すると。。。
 *)
Check true : Prop.                          (* コアーションが使えるようになる。 *)
(**
もし、``Set Printing Coercions`` を指定した
場合は、``*response*``バッファには省略されたis_trueが補われ
て、``is_true true : Prop`` と表示される。
 *)

(**
## Reflect と Reflect補題

``reflect P b`` は、命題Pとbool値bが等価であることを示す。
*)
Inductive reflect (P : Prop) : bool -> Set :=
| ReflectT :   P -> reflect P true
| ReflectF : ~ P -> reflect P false.

(**
ふたつのReflect補題を証明しておく。
あとでbool値等式がLeibniz同値関係が等価であることの説明に使う。
*)

(**
### 補題 iffP

``P<->Q`` のとき、``reflect P b`` なら ``reflect Q b``。

証明の概要：

- ``reflect P true``  で、``P->Q``   なら、``reflect Q true``
- ``reflect P false`` で、``~P->~Q`` なら、``reflect Q false``
- ``P->Q`` だけではだめで、``Q->P`` が必要になる。
*)
Lemma iffP : forall {P Q : Prop} {b : bool},
               reflect P b -> (P -> Q) -> (Q -> P) -> reflect Q b.
Proof.
  intros P Q b HPb HPQ HQP.
  case HPb; intros HP.
  - apply ReflectT. auto.
  - apply ReflectF. auto.
Qed.

(**
### 補題 idP

``reflect (is_true b) b`` は、成立する。

コアーションを使って、``forall b : bool, reflect b b`` と書いてもよい。
*)
Lemma idP : forall {b : bool}, reflect (is_true b) b.
Proof.
  intros b.
  case b.
  - now apply ReflectT.
  - now apply ReflectF.
Qed.

(**
## eqType型

bool値等式が定義された型を導入する。
*)
Record mixin_of (T : Type) :=
  EqMixin {
      op : T -> T -> bool;                         (* opはbool値等式 *)
      a : forall x y : T, reflect (x = y) (op x y) (* opはLeibniz同値関係と等価であること *)
    }.

Record eqType :=
  EqType {
      sort : Type;                          (* 補足1参照 *)
      m : mixin_of sort
    }.
Check sort : eqType -> Type.

(**
実際に使うために、eq_op (``==``) を定義する。
*)
Definition eq_op {T : eqType} := @op (sort T) (m T).
Notation "x == y" := (eq_op x y) (at level 70, no associativity).

Check eq_op : (sort _) -> (sort _) -> bool.
(**
eq_op は3つの引数を取るが、``{}``で囲んだ最初の引数Tはimplicitになる。
``==`` のときもTは省略される。
 *)

Check @eq_op : forall T : eqType, (sort T) -> (sort T) -> bool.
(**
しかし、``@eq_op``とすると、引数Tを指定したり、Checkで見ることができる。
 *)

(**
### 補題 eqP

eq_op は Leibniz同値関係と等価であるという補題を証明しておく。この補題は最後に使う。
*)
Lemma eqP : forall {T : eqType} {x y : sort T}, reflect (x = y) (@eq_op T x y).
Proof.
  intro T.
  case T.
  intros sort m.
  now apply m.
Qed.

(**
## bool型の例
*)

(**
bool型を引数とする、決定可能なbool値等式を定義する。
 *)
Definition eqb (x y : bool) : bool :=
  match x, y with
    | true,  true  => true
    | true,  false => false
    | false, true  => false
    | false, false => true
  end.

(**
bool値等式とLeibniz同値関係の等価性を証明する。
 *)
Lemma bool_eqP : forall (x y : bool), reflect (x = y) (eqb x y).
Proof.
  intros x y.
  apply (iffP idP).
  - now case x; case y.                     (* eqb x y -> x = y *)
  - now case x; case y.                     (* x = y -> eqb x y *)
Qed.

(**
eq と eqb の違い。
 *)
Check eq : bool -> bool -> Prop.      (* Leibniz同値関係 *)
Check eqb : bool -> bool -> bool.     (* bool値等式 *)
Check eqb : bool -> bool -> Prop.     (* bool型からProp型へのコアーションが有効なため。 *)

(**
bool_eqTypeを定義する。

コンストラクタ EqMixin と EqType で、bool と eqb と bool_eqP から、
bool_eqTypeを作る。bool_eqType は eqType型である。
 *)
Definition bool_eqMixin := @EqMixin bool eqb bool_eqP. (* EqMixin bool_eqP でもよい。 *)
Definition bool_eqType := @EqType bool bool_eqMixin.   (* EqType bool_eqMixin でもよい。 *)

Fail Check eq_op true true : bool.          (* ！？ *)
Fail Check true == true : bool.             (* ！？ *)

(**
eq_op にbool型の値が書けない！？

説明：

eq_op (``==``) は、次の型を持つ。
*)
Check @eq_op : forall T : eqType, sort T -> sort T -> bool.
(**
最初の引数を省略せずに、bool_eqType と書いた場合、
*)
Check @eq_op bool_eqType : (sort bool_eqType) -> (sort bool_eqType) -> bool.
(**
``sort bool_eqType`` は bool であるから、
*)
Check @eq_op bool_eqType : bool -> bool -> bool.
(**
以降の引数にはbool型の値を直接書くことができる。
*)
Check @eq_op bool_eqType true true : bool.
(**
しかし、最初の引数``T:=bool_eqType``省略して、以降の引数にtrueを書いた場合、
*)
Fail Check eq_op true true.
(**
``Error: The term "true" has type "bool" while it is expected to have type "sort ?241"``

最初の引数がbool_eqTypeであることが判らないのでエラーになる。指定していないから判らない。
eqType型であることは判っても、そのインスタンスをすべてチェックするわけにはいかない
（インスタンスの一覧表はない）ため。
 *)

(**
そこで、Canonical Structureコマンドによって、
bool_eqTypeをeqType型の値として引数の推論に使うよう、登録する。
このときbool_eqTypeはeqTypeのCanonical Instanceまたは、単にCanonicalと呼ぶ。

ひとたび、最初の引数が``T:=bool_eqType``であると判れば、
（省略しないときと同様に）``sort bool_eqType`` は bool なので、以降の引数にbool型の値を書くことができる。
*)

(**
以上を箇条書きにすると：
1. 最初の引数を省略したeq_opまたは ``==`` に、bool型の値を書いた場合において。
2. eqTypeのカノニカルインスタンスとしてbool_eqTypeが登録されているので、それが見つけられる。
3. eq_opの最初の引数が``T:=bool_eqType``であるとする。
4. eq_opの定義から、以降の引数は、``sort bool_eqType``型 であることになる。
5. ``sort bool_eqType`` は bool である。
6. 以降の引数にbool型の値を書くことが許されるようになる。

つまり、

bool_eqTypeをカノニカルにすると、
省略された最初の引数は、bool_eqType であると推論できるので、
最初の引数を省略したeq_opまたは ``==`` にbool型の値を書いてもよい。
*)

(**
説明（終わり）
*)

(**
Canonical Structureコマンドを使って、bool_eqType を eqTypeのCanonical Instanceにする。
*)
Canonical Structure bool_eqType.            (* 補足2 *)
Print Canonical Projections.                (* bool <- sort ( bool_eqType ) *)

(**
すると。。。

bool型の値に対して、``==`` が使用可能になる。
（eq_opの最初の引数 ``T:=bool_eqType`` が省略できるようになる。）
 *)
Check eq_op true true : bool.
Check true == true : bool.

(**
蛇足：コアーションは、表記上で、型を変換する関数を省略できることである。
一方、カノニカル・ストラクチャーは、省略された引数を推論するためのヒントを登録することである。
*)

(**
## nat型の例
*)

(**
nat型を引数とする、決定可能なbool値等式を定義する。
 *)
Fixpoint eqn m n {struct m} :=
  match m, n with
  | 0, 0 => true
  | S m', S n' => eqn m' n'
  | _, _ => false
  end.

(**
bool値等式とLeibniz同値関係の等価性を証明する。
 *)
Lemma nat_eqP : forall (x y : nat), reflect (x = y) (eqn x y).
Proof.
  intros n m.
  apply (iffP idP).
  (* eqn n m -> n = m *)
  - generalize dependent m.
    induction n; intros m.
    + now destruct m.
    + destruct m as [|m' IHm'].
      * now simpl.
      * simpl. intro H. f_equal.
        now apply IHn.
  (* n = m -> eqn n m *)
  - intros H.
    rewrite <- H.
    now elim n.
Qed.

(**
eq と eqn の違い。
 *)
Check eq : nat -> nat -> Prop.        (* Leibniz同値関係 *)
Check eqn : nat -> nat -> bool.       (* bool値等式 *)
Check eqn : nat -> nat -> Prop.       (* bool型からProp型へのコアーションが有効なため。 *)

(**
nat_eqTypeを定義する。
 *)

Definition nat_eqMixin := @EqMixin nat eqn nat_eqP.   (* EqMixin nat_eqP でもよい。 *)
Definition nat_eqType := @EqType nat nat_eqMixin.     (* EqType nat_eqMixin *)

Fail Check eq_op 1 1 : bool.
Fail Check 1 == 1 : bool.

(**
Canonical Structureコマンドを使って、nat_eqType を eqTypeのCanonical Instanceにする。
*)
Canonical Structure nat_eqType.
Print Canonical Projections.                (* nat <- sort ( nat_eqType ) *)

(**
すると。。。

nat型の値に対して、``==`` が使用可能になる。
（eq_opの最初の引数 ``T:=nat_eqType`` が省略できるようになる。）
 *)
Check eq_op 1 1 : bool.
Check 1 == 1 : bool.

(**
## View

SSReflectでは、``apply/V`` と書くことができ、そのVをViewと呼ぶ。
Viewのみapplyするのではなく、View Hintとして登録された補題が自動的に補われる（場合がある）。

View Hintとして使われることの多い補題に``elimT``と``introT``がある。
それを証明しておく。
*)

Lemma introTF :
  forall {P : Prop} {b c : bool},
    reflect P b ->
    (match c with
       | true => P
       | false => ~ P
     end) ->
    b = c.
Proof.
  intros P b c Hb.
  case c; case Hb; intros H1 H2.
  - reflexivity.
  - exfalso. now apply H1.
  - exfalso. now apply H2.
  - reflexivity.
Qed.

Lemma elimTF :
  forall {P : Prop} {b c : bool},
    reflect P b ->
    b = c ->
    (match c with
       | true => P
       | false => ~ P
     end).
Proof.
  intros P b c Hb Hbc.
  rewrite <- Hbc.
  now case Hb; intro H; apply H.
Qed.

Lemma elimT :
  forall {P : Prop} {b : bool}, reflect P b -> b -> P.
Proof.
  intros P b Hb.
  Check (@elimTF P b true Hb).
  now apply (@elimTF P b true Hb).
Qed.

Lemma introT :
  forall {P : Prop} {b : bool}, reflect P b -> P -> b.
Proof.
  intros P b Hb.
  Check (@introTF P b true Hb).
  now apply (@introTF P b true Hb).
Qed.

(**
## Leibniz同値関係とbool値等式のリフレクション（x = y と x == y の相互変換）の例

SSReflectでは、ゴールが``x = y``のとき、``apply/eqP``を実行することで``x == y``に変換される。
このとき、View Hintとして、elimT が使われる。すなわち、``apply (elimT eqP)`` である。

また、ゴールが``x == y``のとき、おなじく``apply/eqP``を実行することで``x = y``に変換される。
このとき、View Hintとして、introT が使われる。すなわち、``apply (introT eqP)`` である。
*)

(**
boolの場合
*)
Goal forall x y : bool, x == y -> x = y.
Proof.
  intros x y H.
  apply (elimT eqP).                        (* apply/eqP *)
  (* Goal : x == y *)
  apply (introT eqP).                       (* apply/eqP *)
  (* Goal : x = y *)
  apply (elimT eqP).                        (* apply/eqP *)
  (* Goal : x == y *)
  now apply H.
Qed.

(**
natの場合
*)
Goal forall n m : nat, n = m -> n == m.
Proof.
  intros n m H.
  apply (introT eqP).                       (* apply/eqP *)
  (* Goal : n = m *)
  apply (elimT eqP).                        (* apply/eqP *)
  (* Goal : n == m *)
  apply (introT eqP).                       (* apply/eqP *)
  (* Goal : n = m *)
  now apply H.
Qed.

(**
# まとめ

1. 「SSReflectもどき」をつくってみた

2. SSReflect で、Leibniz同値関係 (``x = y``) と bool値等式 (``x == y``) が相互に変換できるのは、
両者が等価であることが、それぞれの型で、証明されているから (bool_eqTypeやnat_eqType)。

3. 上記を実現するために、Coqのコアーション(coersion)や
カノニカル・ストラクチャCanonical Structure)を利用する。
*)

(**
# 補足1

EqType の ``sort : Type`` を ``sort :> Type`` とすることによって、
eqTypeからTypeへのコアーションを有効にできる。
``[sort] : eqType >-> Sortclass``

これによって、``Lemma eqP (T : eqType) : forall {x y : sort T},...``
のsortを省略して、`Lemma eqP (T : eqType) : forall {x y : T},...``と表記できる。

また、eq_op が、
``Check @eq_op bool_eqType : bool_eqType -> bool_eqType -> bool.``
と見えるようになる。

しかし、これはカノニカルによる引数の推論とは全く別のことである。
今回は、それを強調するために、eqTypeのsortによるコアーションを指定しないようにし、
sortによるeqTypeからTypeへの変換は、すべて明示的に指定することにした。
*)

(**
# 補足2

DefinitionとCanonical Structureコマンドをまとめて、
以下のように書くこともできる。

- ``Canonical Structure bool_eqType := @EqType bool bool_eqMixin.``
- ``Canonical Structure nat_eqType := @EqType nat nat_eqMixin.``

SSReflectでは、単にCanonicalである。
*)

(**
# 参考文献

1. アフェルト レナルド 「定理証明支援系 Coq による形式検証」
``https://staff.aist.go.jp/reynald.affeldt/ssrcoq/coq-kyoto2015.pdf``

2. Assia Mahboubi, Enrico Tassi, "Canonical Structures for the working Coq user"
``https://hal.inria.fr/hal-00816703v1/document``

The essence of the Canonical Structures mechanism is to extend the unification algorithm
of the Coq system with a database of hints. (p.3)

2. @suharahiromichi, 「SSReflectのViewとView Hintについてのメモ」
``http://qiita.com/suharahiromichi/items/02c7f42809f2d20ba11a``
*)

(* END *)