Require Export Metalib.Metatheory.
Require Import Definitions.
Require Import LibTactics.
Require Export Metalib.LibLNgen.
Require Import String.

(** Computing free type variables in a type *)

Fixpoint fv_tt (T : typ) {struct T} : atoms :=
  match T with
  | t_int       => {}
  | t_unit     => {}
  | t_bvar J      => {}
  | t_fvar X      => {{ X }}
  | t_arrow T1 T2 => (fv_tt T1) `union` (fv_tt T2)
  | t_all T1      => (fv_tt T1)
  | t_ref T1      => (fv_tt T1)
  end.

Fixpoint fv_te (e : exp) {struct e} : atoms :=
match e with
| e_bvar i       => {}
| e_fvar x       => {}
| e_lit i        => {}
| e_unit        => {}
| e_loc l        => {}
| e_abs A e1   => (fv_tt A) `union` (fv_te e1)
| e_app e1 e2    => (fv_te e1) `union` (fv_te e2)
| e_anno e A     => (fv_te e) `union` (fv_tt A)
| e_tabs e     => (fv_te e)
| e_tapp e A     => (fv_te e) `union` (fv_tt A)
| e_ref e     => (fv_te e)
| e_get e     => (fv_te e)
| e_set e1 e2    => (fv_te e1) `union` (fv_te e2)
end.

(** Computing free expr variables in a expr *)

Fixpoint fv_ee (e : exp) {struct e} : atoms :=
match e with
| e_bvar i       => {}
| e_fvar x       => {{ x }}
| e_lit i        => {}
| e_unit        => {}
| e_loc l        => {}
| e_abs A e1    => (fv_ee e1)
| e_app e1 e2    => (fv_ee e1) `union` (fv_ee e2)
| e_anno e A     => (fv_ee e)
| e_tabs e      => (fv_ee e)
| e_tapp e A     => (fv_ee e)
| e_ref e     => (fv_ee e)
| e_get e     => (fv_ee e)
| e_set e1 e2    => (fv_ee e1) `union` (fv_ee e2)
end.

(** Substitution for free type variables in types. *)

Fixpoint subst_tt (Z : var) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | t_int         => t_int
  | t_unit         => t_unit
  | t_bvar J      => t_bvar J
  | t_fvar X      => if X == Z then U else (t_fvar X)
  | t_arrow T1 T2 => t_arrow (subst_tt Z U T1) (subst_tt Z U T2)
  | t_all T1      => t_all (subst_tt Z U T1)
  | t_ref T1      => t_ref (subst_tt Z U T1)
  end.

Fixpoint subst_te (z : var) (u : typ) (e : exp) {struct e} : exp :=
  match e with
  | e_bvar i       => e_bvar i
  | e_fvar x       => e_fvar x
  | e_lit i        => e_lit i
  | e_unit         => e_unit
  | e_loc l        => e_loc l
  | e_abs A e1    => e_abs (subst_tt z u A) (subst_te z u e1)
  | e_app e1 e2    => e_app (subst_te z u e1) (subst_te z u e2)
  | e_anno e A     => e_anno (subst_te z u e) (subst_tt z u A)
  | e_tabs e      => e_tabs (subst_te z u e)
  | e_tapp e A     => e_tapp (subst_te z u e) (subst_tt z u A)
  | e_ref t1    => e_ref (subst_te z u t1)
  | e_get t1    => e_get (subst_te z u t1)
  | e_set t1 t2 => e_set (subst_te z u t1) (subst_te z u t2)
  end.

(** Substitution for free expr variables in exprs. *)

Fixpoint subst_ee (z : var) (u : exp) (e : exp) {struct e} : exp :=
  match e with
  | e_bvar i       => e_bvar i
  | e_fvar x       => if x == z then u else (e_fvar x)
  | e_lit i        => e_lit i
  | e_unit         => e_unit
  | e_loc l        => e_loc l
  | e_abs A e1    => e_abs A (subst_ee z u e1)
  | e_app e1 e2    => e_app (subst_ee z u e1) (subst_ee z u e2)
  | e_anno e A     => e_anno (subst_ee z u e) A
  | e_tabs e      => e_tabs (subst_ee z u e)
  | e_tapp e A     => e_tapp (subst_ee z u e) A
  | e_ref t1    => e_ref (subst_ee z u t1)
  | e_get t1    => e_get (subst_ee z u t1)
  | e_set t1 t2 => e_set (subst_ee z u t1) (subst_ee z u t2)
  end.

Definition subst_tb (Z : var) (P : typ) (b : binding) : binding :=
  match b with
  | bind_tvar => bind_tvar
  | bind_typ T => bind_typ (subst_tt Z P T)
  end.

(* *********************************************************************** *)
(** * Size *)

Fixpoint size_typ (A1 : typ) {struct A1} : nat :=
match A1 with
  | t_fvar X1 => 1
  | t_bvar n1 => 1
  | t_int => 1
  | t_unit => 1
  | t_all A => 1 + (size_typ A)
  | t_arrow A2 B1 => 1 + (size_typ A2) + (size_typ B1)
  | t_ref A => 1 + (size_typ A)
end.

Fixpoint size_exp (e1 : exp) {struct e1} : nat :=
match e1 with
  | e_fvar x1 => 1
  | e_bvar n1 => 1
  | e_lit i1 => 1
  | e_unit => 1
  | e_abs A1 e2  => 1 + (size_typ A1) + (size_exp e2)
  | e_app e2 e3 => 1 + (size_exp e2) + (size_exp e3)
  | e_anno e2 A1 => 1 + (size_exp e2) + (size_typ A1)
  | e_tabs e2  => 1 + (size_exp e2)
  | e_tapp e2 A1 => 1 + (size_exp e2) + (size_typ A1)
  | e_loc l => 1
  | e_ref e => 1 + (size_exp e)
  | e_get e => 1 + (size_exp e)
  | e_set e2 e3 => 1 + (size_exp e2) + (size_exp e3)
end.

(** Computing free type variables in a env *)

Fixpoint fv_tt_env (E : env) {struct E} : atoms :=
  match E with
  | nil                      => {}
  | cons (x, bind_typ t) E' => fv_tt t `union` fv_tt_env E'
  | cons (x, bind_tvar) E'  => fv_tt_env E'
  end.

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 : exp => fv_te x) in
let D := gather_atoms_with (fun x : exp => fv_ee x) in
let E := gather_atoms_with (fun x : typ => fv_tt x) in
let F := gather_atoms_with (fun x : env => dom x) in
let G := gather_atoms_with(fun x : env => fv_tt_env x) in
constr:(A `union` B `union` C `union` D `union` E `union` F `union` G).

(* ********************************************************************** *)
(** ** Properties of type substitution in types *)

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...
Case "typ_bvar".
  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...
Case "typ_all".
  unfold open_tt in *.
  pick fresh X.
  apply (open_tt_rec_type_aux T2 0 (t_fvar X))...
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...
Case "typ_fvar".
  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_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 (t_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 (t_fvar X)).
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_tt_intro_rec...
Qed.

(* ********************************************************************** *)
(** ** Properties of type substitution in expressions *)

Lemma open_te_rec_expr_aux : forall e j u i P ,
open_ee_rec j u e = open_te_rec i P (open_ee_rec j u e) ->
e = open_te_rec i P e.
Proof with congruence || eauto.
induction e; intros j u i P H; simpl in *; inversion H; f_equal...
Qed.

Lemma open_te_rec_type_aux : forall e j Q i P,
i <> j ->
open_te_rec j Q e = open_te_rec i P (open_te_rec j Q e) ->
e = open_te_rec i P e.
Proof.
induction e; intros j Q i P Neq Heq; simpl in *; inversion Heq;
  f_equal; eauto using open_tt_rec_type_aux.
Qed.

Lemma open_te_rec_expr : forall e U k,
expr e ->
e = open_te_rec k U e.
Proof.
intros e U k WF. revert k.
induction WF; intros k; simpl; f_equal;
auto using open_tt_rec_type;
try solve [
  unfold open_ee in *;
  pick fresh x;
  eapply open_te_rec_expr_aux with (j := 0) (u := e_fvar x);
  auto
| unfold open_te in *;
  pick fresh X;
  eapply open_te_rec_type_aux with (j := 0) (Q := t_fvar X);
  auto
].
Qed.

Lemma subst_te_open_te_rec : forall e T X U k,
type U ->
subst_te X U (open_te_rec k T e) =
  open_te_rec k (subst_tt X U T) (subst_te X U e).
Proof.
intros e T X U k WU. revert k.
induction e; intros k; simpl; f_equal; auto using subst_tt_open_tt_rec.
Qed.

Lemma subst_te_open_te_var : forall (X Y:atom) U e,
Y <> X ->
type U ->
open_te (subst_te X U e) Y = subst_te X U (open_te e Y).
Proof with congruence || auto.
intros X Y U e Neq WU.
unfold open_te.
rewrite subst_te_open_te_rec...
simpl.
destruct (Y == X)...
Qed.

Lemma subst_te_intro_rec : forall X e U k,
X `notin` fv_te e ->
open_te_rec k U e = subst_te X U (open_te_rec k (t_fvar X) e).
Proof.
induction e; intros U k Fr; simpl in *; f_equal;
  auto using subst_tt_intro_rec.
Qed.

Lemma subst_te_intro : forall X e U,
X `notin` fv_te e ->
open_te e U = subst_te X U (open_te e (t_fvar X)).
Proof with auto.
intros.
unfold open_te.
apply subst_te_intro_rec...
Qed.

Lemma subst_te_open_ee_rec : forall e1 e2 Z P k,
subst_te Z P (open_ee_rec k e2 e1) =
  open_ee_rec k (subst_te Z P e2) (subst_te Z P e1).
Proof with auto.
induction e1; intros e2 Z P k; simpl; f_equal...
Case "exp_bvar".
  destruct (k === n)...
Qed.

Lemma subst_te_open_ee : forall e1 e2 Z P,
subst_te Z P (open_ee e1 e2) = open_ee (subst_te Z P e1) (subst_te Z P e2).
Proof with auto.
intros.
unfold open_ee.
apply subst_te_open_ee_rec...
Qed.

Lemma subst_te_open_ee_var : forall Z (x:atom) P e,
open_ee (subst_te Z P e) x = subst_te Z P (open_ee e x).
Proof with auto.
intros.
rewrite subst_te_open_ee...
Qed.

(* ********************************************************************** *)
(** ** Properties of expression substitution in expressions *)

Lemma subst_ee_fresh : forall (x: atom) u e,
x `notin` fv_ee e ->
e = subst_ee x u e.
Proof with auto.
intros x u e; induction e; simpl; intro H; f_equal...
Case "exp_fvar".
  destruct (a==x)...
  contradict H; fsetdec.
Qed.

Lemma subst_ee_intro_rec : forall x e u k,
x `notin` fv_ee e ->
open_ee_rec k u e = subst_ee x u (open_ee_rec k (e_fvar x) e).
Proof with congruence || auto.
induction e; intros u k Fr; simpl in *; f_equal...
-
   destruct (k === n)... simpl. destruct (x == x)...
-
  destruct (a == x)... contradict Fr; fsetdec.
Qed.

Lemma subst_ee_intro : forall x e u,
x `notin` fv_ee e ->
open_ee e u = subst_ee x u (open_ee e (e_fvar x)).
Proof with auto.
intros.
unfold open_ee.
apply subst_ee_intro_rec...
Qed.

Lemma open_ee_rec_expr_aux : forall e j v u i,
i <> j ->
open_ee_rec j v e = open_ee_rec i u (open_ee_rec j v e) ->
e = open_ee_rec i u e.
Proof with congruence || eauto.
induction e; intros j v u i Neq H; simpl in *; inversion H; f_equal...
Case "exp_bvar".
  destruct (j===n)... destruct (i===n)...
Qed.

Lemma open_ee_rec_type_aux : forall e j V u i,
open_te_rec j V e = open_ee_rec i u (open_te_rec j V e) ->
e = open_ee_rec i u e.
Proof.
induction e; intros j V u i H; simpl; inversion H; f_equal; eauto.
Qed.

Lemma open_ee_rec_expr : forall u e k,
expr e ->
e = open_ee_rec k u e.
Proof with auto.
intros u e k Hexpr. revert k.
induction Hexpr; intro k; simpl; f_equal; auto*;
try solve [
  unfold open_ee in *;
  pick fresh x;
  eapply open_ee_rec_expr_aux with (j := 0) (v := e_fvar x);
  auto
| unfold open_te in *;
  pick fresh X;
  eapply open_ee_rec_type_aux with (j := 0) (V := t_fvar X);
  auto
].
Qed.

Lemma subst_ee_open_ee_rec : forall e1 e2 x u k,
expr u ->
subst_ee x u (open_ee_rec k e2 e1) =
  open_ee_rec k (subst_ee x u e2) (subst_ee x u e1).
Proof with auto.
intros e1 e2 x u k WP. revert k.
induction e1; intros k; simpl; f_equal...
Case "exp_bvar".
  destruct (k === n); subst...
Case "exp_fvar".
  destruct (a == x); subst... apply open_ee_rec_expr...
Qed.

Lemma subst_ee_open_ee : forall e1 e2 x u,
expr u ->
subst_ee x u (open_ee e1 e2) =
  open_ee (subst_ee x u e1) (subst_ee x u e2).
Proof with auto.
intros.
unfold open_ee.
apply subst_ee_open_ee_rec...
Qed.

Lemma subst_ee_open_ee_var : forall x y u e,
 y <> x ->
 expr u ->
(subst_ee x u e) open_ee_var y = subst_ee x u (e open_ee_var y).
Proof with congruence || auto.
intros x y u e Neq Wu.
unfold open_ee.
rewrite subst_ee_open_ee_rec...
simpl.
destruct (y == x)...
Qed.

Lemma subst_ee_open_te_rec : forall e P z u k,
expr u ->
subst_ee z u (open_te_rec k P e) = open_te_rec k P (subst_ee z u e).
Proof with auto.
induction e; intros P z u k H; simpl; f_equal...
Case "exp_fvar".
  destruct (a == z)... apply open_te_rec_expr...
Qed.

Lemma subst_ee_open_te : forall e P z u,
expr u ->
subst_ee z u (open_te e P) = open_te (subst_ee z u e) P.
Proof with auto.
intros.
unfold open_te.
apply subst_ee_open_te_rec...
Qed.

Lemma subst_ee_open_te_var : forall z X u e,
expr u ->
open_te (subst_ee z u e) X = subst_ee z u (open_te e X).
Proof with auto.
intros z X u e H.
rewrite subst_ee_open_te...
Qed.

Scheme typ_ind' := Induction for typ Sort Prop.

Definition typ_mutind :=
fun H1 H2 H3 H4 H5 H6 H7 =>
typ_ind' H1 H2 H3 H4 H5 H6 H7.

Scheme exp_ind' := Induction for exp Sort Prop.

Definition exp_mutind :=
fun H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 =>
exp_ind' H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12.

Ltac default_auto ::= auto with arith lngen.

Lemma size_exp_open_exp_wrt_exp_rec_var_mutual :
(forall e1 x1 n1,
  size_typ (open_tt_rec n1 (t_fvar x1) e1) = size_typ e1).
Proof.
apply_mutual_ind typ_mutind;
default_simp.
Qed.

Lemma size_exp_open_exp_wrt_exp_rec_var :
forall e1 x1 n1,
  size_typ (open_tt_rec n1 (t_fvar x1) e1) = size_typ e1.
Proof.
pose proof size_exp_open_exp_wrt_exp_rec_var_mutual as H; intuition eauto.
Qed.

Lemma size_open_tt :
forall e1 x1,
  size_typ (open_tt e1 (t_fvar x1)) = size_typ e1.
Proof.
  unfold open_tt;intros.
  rewrite size_exp_open_exp_wrt_exp_rec_var.
  reflexivity.
Qed.

Lemma fv_ee_open_ee_lower_aux : forall e1 n e2, (*3178*)
fv_ee e1 [<=] fv_ee (open_ee_rec n e2 e1).
Proof.
apply_mutual_ind exp_mutind;
default_simp; fsetdec.
Qed.

Lemma fv_ee_open_te_lower_aux : forall e1 n e2, (*3178*)
fv_ee e1 [<=] fv_ee (open_te_rec n e2 e1).
Proof.
apply_mutual_ind exp_mutind;
default_simp; fsetdec.
Qed.

Lemma fv_tt_open_tt_lower_aux : forall A n B, (*3178*)
fv_tt A [<=] fv_tt (open_tt_rec n B A).
Proof.
apply_mutual_ind typ_mutind;
default_simp; fsetdec.
Qed.

Lemma fv_ee_open_ee_lower : forall e1 e2,
fv_ee e1 [<=] fv_ee (open_ee e1 e2).
Proof.
intros.
unfold open_ee.
apply* fv_ee_open_ee_lower_aux.
Qed.

Lemma fv_ee_open_te_lower :
forall e1 A1,
fv_ee e1 [<=] fv_ee (open_te e1 A1).
Proof.
intros.
unfold open_te; simpl; try fsetdec.
apply* fv_ee_open_te_lower_aux.
Qed.

Lemma fv_tt_open_tt_lower :
forall e1 A1,
fv_tt e1 [<=] fv_tt (open_tt e1 A1).
Proof.
intros.
unfold open_tt; simpl; try fsetdec.
apply* fv_tt_open_tt_lower_aux.
Qed.

Definition irred e mu mu': Prop := forall b, ~(step (e, mu) (b, mu')).

Lemma step_not_value: forall (v:exp) mu mu',
  value v -> irred v mu mu'.
Proof.
introv.
unfold irred.
inductions v; introv H;
inverts* H;
unfold not;intros;
try solve[inverts* H;
try solve[
destruct F; unfold fill in H0; inverts* H0];
try solve[inverts* H7];
try solve[inverts* H2;inverts H4]];
try solve[inverts* H;
try solve[
destruct F; unfold fill in H1; inverts* H1];
try solve[inverts* H0];
try solve[inverts* H2;inverts H4]].
Qed.

(* Notation "Γ ⊢ E => A" := (typing Γ E Inf A) (at level 45).
Notation "Γ ⊢ E <= A" := (typing Γ E Chk A) (at level 45). *)
(* Notation "E |- A ~~ B" := (eq E A B) (at level 49). *)
(* Notation "A << B" := (tpre A B) (at level 45).
Notation "e1 <<< e2" := (epre e1 e2) (at level 45). *)

Notation "[ z ~> u ] e" := (subst_ee z u e) (at level 0).
Notation "t ^^ u"       := (open_ee t u) (at level 67).
Notation "e ^ x"        := (open_ee e (e_fvar x)).

Notation "v |-> A v'" := (TypedReduce v A v') (at level 68).
Notation "e ~-> r" := (step e r) (at level 68).

(* Notation "t ->* r" := (steps t r) (at level 68).

Lemma star_one:
forall a b, step a (r_e b) -> steps a (r_e b).
Proof.
eauto using steps.
Qed.

Lemma star_trans:
forall a b, steps a (r_e b) -> forall c, steps b (r_e c) -> steps a (r_e c).
Proof.
  introv H.
  inductions H; eauto using steps.
Qed.

Lemma star_transb:
forall a b, steps a (r_e b) -> steps b r_blame -> steps a r_blame.
Proof.
  introv H.
  inductions H; eauto using steps.
Qed.

Hint Resolve star_one star_trans star_transb: core. *)

(* *********************************************************************** *)
(** * ## Properties of [body_e] *)

(** The two kinds of facts we need about [body_e] are the following:
      - How to use it to derive that terms are locally closed.
      - How to derive it from the facts that terms are locally closed.

    Since we use it only in the context of [exp_let] and [exp_sum]
    (see the definition of reduction), those two constructors are the
    only ones we consider below. *)

  (* *********************************************************************** *)
  (** * ## Automation *)

  (** We add as hints the fact that local closure is preserved under
      substitution.  This is part of our strategy for automatically
      discharging local-closure proof obligations. *)

  Hint Extern 1 (binds _ (?F (subst_tt ?X ?U ?T)) _) =>
    unsimpl (subst_tb X U (F T)) : core.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable inAngle_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defcollinear_1 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_2 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_3 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_4 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_5 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_6 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_7 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_layoff_8 : (forall A B C D : Universe, (exists X : Universe, ((A <> B /\ C <> D) -> (out_ A B X /\ cong_ A X C D)))).
Variable lemma_rayimpliescollinear_9 : (forall A B C : Universe, (out_ A B C -> col_ A B C)).
Variable lemma_collinearorder_10 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_raystrict_11 : (forall A B C : Universe, (out_ A B C -> A <> C)).
Variable lemma_inequalitysymmetric_12 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_collinear4_13 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable proposition_10_14 : (forall A B : Universe, (exists X : Universe, (A <> B -> (betS_ A X B /\ cong_ X A X B)))).
Variable cn_congruencereflexive_15 : (forall A B : Universe, cong_ A B A B).
Variable lemma_congruencesymmetric_16 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_doublereverse_17 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ D C B A /\ cong_ B A D C))).
Variable lemma_betweennotequal_18 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_ray4_1_19 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_20 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_21 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable defequalangles_22 : (forall A B C Ca Cb Cc : Universe, (exists U V Su Sv : Universe, (congA_ A B C Ca Cb Cc -> (out_ B A U /\ (out_ B C V /\ (out_ Cb Ca Su /\ (out_ Cb Cc Sv /\ (cong_ B U Cb Su /\ (cong_ B V Cb Sv /\ (cong_ U V Su Sv /\ ~(col_ A B C))))))))))).
Variable defequalangles2_23 : (forall A B C Ca Cb Cc U V Su Sv : Universe, ((out_ B A U /\ (out_ B C V /\ (out_ Cb Ca Su /\ (out_ Cb Cc Sv /\ (cong_ B U Cb Su /\ (cong_ B V Cb Sv /\ (cong_ U V Su Sv /\ ~(col_ A B C)))))))) -> congA_ A B C Ca Cb Cc)).
Variable lemma_equalanglessymmetric_24 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable lemma_ABCequalsCBA_25 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C C B A)).
Variable lemma_equalanglestransitive_26 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable definterior_27 : (forall A B C P : Universe, (exists X Y : Universe, (inAngle_ A B C P -> (out_ B A X /\ (out_ B C Y /\ betS_ X P Y))))).
Variable definterior2_28 : (forall A B C P X Y : Universe, ((out_ B A X /\ (out_ B C Y /\ betS_ X P Y)) -> inAngle_ A B C P)).

Theorem proposition_09_29 : (forall A B C : Universe, (exists X : Universe, (~(col_ B A C) -> (congA_ B A X X A C /\ inAngle_ B A C X)))).
Proof.
  time tac.
Qed.

End FOFProblem.


(** CoRN has several definitions of constructive reals : IR, CR, AR.
    CR, and then AR was designed to get faster and faster
    computations with reals.
    So, this interface attempts to axiomatize a fast real and common operations on it,
    so that most of our development can be independent of the choice of a fast implementation.
    The [CReal] interface is a nice starting point. It a [CField] with ordering and
    cauchy limits.
    There is Coq proof that all implementaions of [CReal] are isomorphic.

    However, that interface is not sufficient.
    Even when one fixes a representation of reals, there are several
    increasingly fast ways of computing functions like sine, cosine, division
    (e.g. [CRinv] vs [CRinvT])
    which show up often in robotic / cyber-physical programs.
    So, we also include such functions, even though they are definable w.r.t [CReals].

    A bureaocratic problem with [CReal] is that it uses the old bundled style
    and not the modern more convenient typeclass based style of MathClasses.
    We use the latter style.

    We will provide implementations using CR and AR.
    It is quite likely that in the future there will be much faster implementations.

    This file is a work in progress.
*)

Class MinClass (A:Type) := min : A -> A -> A.
Class MaxClass (A:Type) := max : A -> A -> A.

(** generalized Sin Class. The domain may be some kind of (approx) rationals *)
Class GSinClass (B  A : Type) := gsin :  B->A.
Class GCosClass (B  A : Type) := gcos :  B->A.

Class SinClass (A:Type) := sin :> GSinClass A A.
Class CosClass (A:Type) := cos :> GCosClass A A.

Class ApartT (A:Type) := apartT: A -> A -> Type.

Require Import MathClasses.interfaces.canonical_names.

(*reciprocal. generalizes [CRinvT], which uses the constructive proof of
apartness during division *)
Class ReciprocalT (A:Type ) `{Zero A} `{ApartT A}
  := recipT: forall (a:A), apartT a 0 -> A.

Definition NonZeroT (A:Type) {_:ApartT A} {_:Zero A}
  := sigT (fun a => apartT a (0:A)).

(* Arguments NonZeroT A {_} {_}. *)

Definition recip1T {A:Type} {_:ApartT A} {_:Zero A} {_ : ReciprocalT A}
  (a: NonZeroT A) := recipT (projT1 a) (projT2 a).

Infix "≭" := apartT (at level 75, no associativity) : mc_scope.

Require Import ROSCOQ.IRMisc.CoRNMisc.
(**because most of the theory of analysis in CoRN is built for IR. These might
be derivable. the following functions are not used yet.*)
Class IsoToIR (A:Type) := isoToIR : A -> IR.
Class IsoFromIR (A:Type) := isoFromIR : IR -> A.


From Coq Require Import ssreflect ssrfun ssrbool.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import Arith.PeanoNat.
Require Import Coq.Lists.List.
Require Import Relations.Relation_Operators.
Require Import Relations.Operators_Properties.

Require Import utlc.
Import LCNotations.

Open Scope lc_scope.

(* We use a uniform approach to terms and types: they both are lambda terms. *)

(* For types we posit a fundamental term representing types. *)
Axiom typeTp: LC.
Axiom typeTpClosed: LC.

Hint Resolve typeTpClosed : lc_step_db.

(* and a fundamental term representing function types, i.e. funTp A B represents the function type A => B. *)
Axiom funTp : LC.
Axiom funTpClosed : closed funTp.

Hint Resolve funTpClosed : lc_step_db.

Notation "A '=>' B" := (funTp A B) (at level 60, right associativity).

(* with de Bruijn indices our context just needs to be a list of types *)
Definition TpCtx := list LC.

(* colon instead of 'of' didn't work *)
Reserved Notation "Gamma '|-' s 'of' t" (at level 65).

Inductive TpJudgement : TpCtx -> LC -> LC -> Prop :=
  | tpOfType: forall ctx tp, ctx |- tp of typeTp

  | tpOfVar: forall ctx n tp,

       nth_error ctx n = Some tp
    -> ctx |- (#n) of tp

  | tpOfApp: forall ctx s t A B,

       ctx |- s of (A => B)
    -> ctx |- t of A
    -> ctx |- (s t) of B

  | tpOfLam: forall ctx t A B B',
       variablesUpticked B B'
    -> (cons A ctx) |- t of B'
    -> ctx |- (\ t) of (A => B)

  | eqTp: forall ctx t A B,
       A <-->* B
    -> ctx |- t of A
    -> ctx |- t of B

  | depTp: forall ctx t depTp,
       (forall tpInstance, closed tpInstance -> ctx |- t of ((\ depTp) tpInstance))
    -> ctx |- t of (\ depTp)

where "Gamma '|-' s 'of' t" := (TpJudgement Gamma s t).

Notation "'|-' s 'of' t" := (nil |- s of t) (at level 65).

Example identityTypeExtensional: forall A, closed A -> |- (\ #0) of (A => A).
Proof.
  move => ? ?.
  by apply: tpOfLam; [apply: ClosedTermsStableUnderUpticking|constructor].
Qed.

Example identityTypeIntensional: |- (\ #0) of (\ #0 => #0).
Proof.
  apply: depTp.
  move => ? ?.
  apply: eqTp.
  - by apply: rst_sym; do ! constructor; auto with lc_step_db.
  - by apply: identityTypeExtensional.
Qed.

Definition lc_product_type := \ \ \ (#2) => (#1) => (#0).

Example lc_pair_type: |- lc_pair of (\ \ #1 => #0 => lc_product_type (#1) (#0)).
Proof.
  have abc: (closed lc_product_type). admit.
  apply: depTp => ? ?.
  apply: eqTp.
  - by apply: rst_sym; do ! constructor; auto with lc_step_db.
  - apply: eqTp.
    + apply: rst_sym. do ! constructor; auto with lc_step_db.
      econstructor.
      * by apply: ClosedTermsStableUnderUpticking.
      * do ! constructor.
        ** by apply: NClosedTermsStableUnderNSubstitution; auto with lc_step_db.
        ** by apply: NClosedTermsStableUnderNSubstitution; auto with lc_step_db.
        ** apply: NClosedTermsStableUnderNSubstitution; auto with lc_step_db.
    + do ! constructor => ? ?.
      apply: eqTp.
      * apply: rst_sym. do ! constructor; auto with lc_step_db.
      * do ! constructor.

Definition lc_list_type := \ #0 => (#0 => #0) => #0.
Definition lc_list_type_for (A: LC) := A => (A => A) => A.

Example lc_nil_type: |- lc_nil of lc_list_type.
Proof.
  apply: depTp => ? ?.
  apply: eqTp.
  - by apply: rst_sym; do ! constructor; auto with lc_step_db.
  - do ! constructor.
Qed.

Example lc_cons_type: |- lc_cons of (\ #0 => lc_list_type_for (#0) => lc_list_type_for (#0)).
Proof.
  apply: depTp => A ?.
  apply: eqTp.
  - by apply: rst_sym; do ! constructor; auto with lc_step_db.
  - do ! constructor.
Qed.


Require Import Crypto.Spec.WeierstrassCurve.
Require Import Crypto.Algebra.Field.
Require Import Crypto.Util.Decidable Crypto.Util.Tactics.DestructHead Crypto.Util.Tactics.BreakMatch.

Module W.
  Section W.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv} {a b:F}
            {field:@Algebra.Hierarchy.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {Feq_dec:DecidableRel Feq}.

    Program Definition opp (P:@W.point F Feq Fadd Fmul a b) : @W.point F Feq Fadd Fmul a b
      := match W.coordinates P return F*F+_ with
         | inl (x1, y1) => inl (x1, Fopp y1)
         | inr tt => inr tt
         end.
    Next Obligation.
      cbv [W.coordinates]; break_match; trivial; fsatz.
    Qed.
  End W.
End W.


From Autosubst Require Export Autosubst.
From logrel_ifc.lambda_sec Require Export lang lattice.

Section syntactic_flowsto.

  Inductive label_term `{SecurityLattice label} :=
  | LVar (x : var)
  | LJoin (l l' : label_term)
  | LLabel (ℓ : label).

  Context `{SecurityLattice label}.

  Global Instance label_term_ids : Ids label_term . Proof. derive. Defined.
  Global Instance label_term_rename : Rename label_term . Proof. derive. Defined.
  Global Instance label_term_subst : Subst label_term . Proof. derive. Defined.
  Global Instance label_term_substlemmas : SubstLemmas label_term . derive. Defined.

  Inductive flowsto : label_term → label_term  → Prop :=
  | FRefl l :
      flowsto l l
  | FTrans l1 l2 l3 :
      flowsto l1 l2 →
      flowsto l2 l3 →
      flowsto l1 l3
  | FBottom l :
      flowsto (LLabel ⊥) l
  | FTop l :
      flowsto l (LLabel ⊤)
  | FLabel ℓ1 ℓ2 :
      ℓ1 ⊑ ℓ2 →
      flowsto (LLabel ℓ1) (LLabel ℓ2)
  | FJoin l1 l2 l3 :
      flowsto l1 l3 →
      flowsto l2 l3 →
      flowsto (LJoin l1 l2) l3.

  Global Instance flowsto_refl : Reflexive flowsto.
  Proof. by constructor. Qed.

  Global Instance flowsto_trans : Transitive flowsto.
  Proof. by econstructor. Qed.

End syntactic_flowsto.

Notation "a ⊑ₛ b" := (flowsto a b) (at level 70) : stdpp_scope.
Infix "⊔ₛ" := (LJoin) (at level 50) : stdpp_scope.
Notation "⊥ₛ" := (LLabel bot) : stdpp_scope.
Notation "⊤ₛ" := (LLabel top) : stdpp_scope.

Global Hint Constructors flowsto : core.

Section lambda_sec_types.
  Context `{SecurityLattice label}.

  Inductive type :=
  | TUnit
  | TBool
  | TNat
  | TVar (x : var)
  | TRef (τ : sectype)
  | TArrow (ℓₑ : label_term) (τ1 τ2 : sectype)
  | TProd (τ1 τ2 : sectype)
  | TSum (τ1 τ2 : sectype)
  | TForall (ℓₑ : label_term) (τ : sectype)
  | TLForall (ℓₑ : label_term) (τ : sectype)
  | TExist (τ : sectype)
  | TRec (τ : sectype)
  with sectype :=
  | TSec (ℓ : label_term) (t : type).

  Implicit Types t : type.
  Implicit Types τ : sectype.

  (* generate mutual induction principles *)
  Scheme type_mut := Induction for type Sort Prop
    with sectype_mut := Induction for sectype Sort Prop.

  Notation "t @ ℓ" := (TSec ℓ t) (at level 40).

  (* -------------------- autosubst lemmas -------------------- *)

  Global Instance Ids_type : Ids type. derive. Defined.
  Global Instance Ids_sectype : Ids sectype := λ n, TSec ⊥ₛ TUnit.

  Fixpoint hsubst_label_type (sigma : var → label_term) (t : type) : type :=
    let _ := hsubst_label_sectype : HSubst label_term sectype in
    match t with
    | TUnit
    | TBool | TNat => t
    | TVar x => TVar x
    | TRef τ => TRef (hsubst sigma τ)
    | TArrow ℓ' τ1 τ2 => TArrow ℓ'.[sigma] (hsubst sigma τ1) (hsubst sigma τ2)
    | TProd τ1 τ2 => TProd (hsubst sigma τ1) (hsubst sigma τ2)
    | TSum τ1 τ2 => TSum (hsubst sigma τ1) (hsubst sigma τ2)
    | TForall ℓ τ => TForall ℓ.[sigma] (hsubst sigma τ)
    | TLForall ℓ τ => TLForall ℓ.[up sigma] (hsubst (up sigma) τ)
    | TExist τ => TExist (hsubst sigma τ)
    | TRec τ => TRec (hsubst sigma τ)
    end
  with hsubst_label_sectype (sigma : var → label_term) (τ : sectype) : sectype :=
    let _ := hsubst_label_type : HSubst label_term type in
    match τ with
    | t @ ℓ => (hsubst sigma t) @ ℓ.[sigma]
    end.

  Global Instance HSubst_label_type : HSubst label_term type := hsubst_label_type.
  Global Instance HSubst_label_sectype : HSubst label_term sectype := hsubst_label_sectype.

  Local Lemma hsubst_label_type_id (t : type) : t.|[ids] = t
  with hsubst_label_sectype_id (τ : sectype) : τ.|[ids] = τ.
  Proof.
    - destruct t; rewrite /= ?up_id ?subst_id ?hsubst_label_sectype_id //.
    - destruct τ; rewrite /= hsubst_label_type_id subst_id //.
  Qed.

  Local Lemma hsubst_label_type_comp (theta eta : var → label_term) (t : type) :
    t.|[theta].|[eta] = t.|[theta >> eta]
  with hsubst_label_sectype_comp (theta eta : var → label_term) (τ : sectype) :
    τ.|[theta].|[eta] = τ.|[theta >> eta].
  Proof.
    - destruct t; rewrite /= ?subst_comp ?hsubst_label_sectype_comp ?up_comp //.
    - destruct τ; rewrite /= hsubst_label_type_comp subst_comp //.
  Qed.

  Global Instance HSubstLemmas_label_type : HSubstLemmas label_term type.
  Proof.
    split.
    - apply hsubst_label_type_id.
    - by simpl.
    - apply hsubst_label_type_comp.
  Qed.

  Global Instance HSubstLemmas_label_sectype : HSubstLemmas label_term sectype.
  Proof.
    split.
    - apply hsubst_label_sectype_id.
    - by intros; simpl.
    - apply hsubst_label_sectype_comp.
  Qed.

  Fixpoint rename_type (xi : var → var) (t : type) : type :=
    let _ := rename_sectype : Rename sectype in
    match t with
    | TUnit
    | TBool | TNat => t
    | TVar x => TVar (xi x)
    | TRef τ => TRef (rename xi τ)
    | TArrow ℓ' τ1 τ2 => TArrow ℓ' (rename xi τ1) (rename xi τ2)
    | TProd τ1 τ2 => TProd (rename xi τ1) (rename xi τ2)
    | TSum τ1 τ2 => TSum (rename xi τ1) (rename xi τ2)
    | TForall ℓ τ => TForall ℓ (rename (upren xi) τ)
    | TLForall ℓ τ => TLForall ℓ (rename xi τ)
    | TExist τ => TExist (rename (upren xi) τ)
    | TRec τ => TRec (rename (upren xi) τ)
    end
  with rename_sectype (xi : var → var) (τ : sectype) : sectype :=
    let _ := rename_type : Rename type in
    match τ with
    | t @ ℓ => (rename xi t) @ ℓ
    end.

  Global Instance Rename_type : Rename type := rename_type.
  Global Instance Rename_sectype : Rename sectype := rename_sectype.

  Fixpoint subst_type (sigma : var → type) (t : type) : type :=
    let _ := hsubst_sectype : HSubst type sectype in
    match t with
    | TUnit
    | TBool | TNat => t
    | TVar x => sigma x
    | TRef τ => TRef (hsubst sigma τ)
    | TArrow ℓ' τ1 τ2 => TArrow ℓ' (hsubst sigma τ1) (hsubst sigma τ2)
    | TProd τ1 τ2 => TProd (hsubst sigma τ1) (hsubst sigma τ2)
    | TSum τ1 τ2 => TSum (hsubst sigma τ1) (hsubst sigma τ2)
    | TForall ℓ τ => TForall ℓ (hsubst (up sigma) τ)
    | TLForall ℓ τ => TLForall ℓ (hsubst (sigma >>| ren (+1)) τ)
    | TExist τ => TExist (hsubst (up sigma) τ)
    | TRec τ => TRec (hsubst (up sigma) τ)
    end
  with hsubst_sectype (sigma : var → type) (τ : sectype) : sectype :=
    let _ := subst_type : Subst type in
    match τ with
    | t @ ℓ => (subst sigma t) @ ℓ
    end.

  Global Instance Subst_type : Subst type := subst_type.
  Global Instance HSubst_type : HSubst type sectype := hsubst_sectype.

  Local Lemma ren_label_subst_type xi (sigma : var → type) n :
    (xi >>> (λ x : var, (sigma x).|[@ren label_term _ (+n)])
     = λ x : var, (sigma (xi x)).|[@ren label_term _ (+n)]).
  Proof.
    apply FunctionalExtensionality.functional_extensionality; by intros x; asimpl.
  Qed.

  Local Lemma rename_subst_comp_type xi sigma t :
    (rename xi t).[sigma] = t.[xi >>> sigma]
  with rename_hsubst_sectype_comp xi sigma τ :
    (rename xi τ).|[sigma] = τ.|[xi >>> sigma].
  Proof.
    - destruct t;
        repeat (match goal with τ : sectype |- _ => destruct τ end);
        rewrite /= ?rename_subst_comp_type // up_comp_ren_subst //.
    - by destruct τ; simpl; f_equal.
  Qed.

  Local Lemma rename_subst_ren xi t : rename xi t = t.[ren xi]
  with rename_hsubst_ren xi τ : rename xi τ = τ.|[ren xi].
  Proof.
    - destruct t;
        repeat (match goal with τ : sectype |- _ => destruct τ end);
        rewrite /= ?rename_subst_ren // up_upren_internal //.
    - by destruct τ; simpl; f_equal.
  Qed.

  Local Lemma rename_subst_subst_comp xi sigma t :
    (rename xi t).[sigma] = t.[xi >>> sigma]
  with rename_hsubst_secsubst_comp xi sigma τ :
    (rename xi τ).|[sigma] = τ.|[xi >>> sigma].
  Proof.
    - destruct t; simpl;
        repeat (match goal with τ : sectype |- _ => destruct τ end); simpl;
          rewrite ?rename_subst_subst_comp // up_comp_ren_subst //.
    - by destruct τ; simpl; f_equal.
  Qed.

  Local Lemma rename_type_label_subst_commute xi t s :
    rename xi t.|[s] = (rename xi t).|[s].
  Proof.
    move: xi s. refine ((fix f t xi s {struct t} := _) t).
    destruct t;
      repeat (match goal with τ : sectype |- _ => destruct τ end);
      simpl; rewrite ?f //.
  Qed.

  Local Lemma rename_type_ren_label xi (sigma : var → type) :
    (λ x : var, (sigma x).|[ren (+1)]) >>> rename xi
    = sigma >>> rename xi >>| ren (+1).
  Proof.
    apply FunctionalExtensionality.functional_extensionality.
    intros. asimpl. apply rename_type_label_subst_commute.
  Qed.

  Local Lemma rename_subst_comp_type_rename sigma xi t :
    rename xi t.[sigma] = t.[sigma >>> rename xi]
  with rename_hsubst_sectype_comp_rename sigma xi τ :
    rename xi τ.|[sigma] = τ.|[sigma >>> rename xi].
  Proof.
    - destruct t; simpl;
        repeat (match goal with τ : sectype |- _ => destruct τ end);
        simpl; try rewrite ?rename_subst_comp_type_rename //.
      + repeat f_equal. rewrite up_comp_subst_ren_internal //.
        * apply rename_subst_ren.
        * apply rename_subst_subst_comp.
      + rewrite rename_type_ren_label //.
      + repeat f_equal. rewrite up_comp_subst_ren_internal //.
        * apply rename_subst_ren.
        * apply rename_subst_subst_comp.
      + repeat f_equal. rewrite up_comp_subst_ren_internal //.
        * apply rename_subst_ren.
        * apply rename_subst_subst_comp.
    - by destruct τ; simpl; f_equal.
  Qed.

  Lemma rename_subst xi t : rename xi t = t.[ren xi]
  with rename_hsubst xi τ : rename xi τ = τ.|[ren xi].
  Proof.
    - destruct t; simpl; rewrite ?rename_hsubst //; f_equal; autosubst.
    - by destruct τ; simpl; f_equal.
  Qed.

  Lemma subst_type_id t : t.[ids] = t
  with hsubst_id τ : τ.|[ids] = τ.
  Proof.
    - assert (up_id : up ids = ids :> (var → type))
        by (apply up_id_internal; reflexivity).
      destruct t; simpl;
        repeat (match goal with τ : sectype |- _ => destruct τ end);
        simpl; rewrite ?up_id ?subst_type_id //.
    - by destruct τ; simpl; f_equal.
  Qed.

  Lemma up_hcomp_dist (sigma : var → type) theta :
    up (sigma >>| theta) = up sigma >>| theta.
  Proof.
    rewrite up_hcomp_internal //; auto using rename_type_label_subst_commute.
  Qed.

  Lemma upn_hsubst_ren n t :
    upn n (t .: ids) >>| ren (+1) = upn n (t.|[ren (+1)] .: ids).
  Proof.
    by rewrite -up_hcomp_n_internal; [|apply up_hcomp_dist]; asimpl.
  Qed.

  Lemma hsubst_label_subst_type_commute t tau sigma :
    t.|[sigma].[tau >>| sigma] = t.[tau].|[sigma].
  Proof.
    move: sigma tau. refine ((fix IH t sigma tau {struct t} := _) t).
    destruct t;
      repeat (match goal with τ : sectype |- _ => destruct τ end);
      simpl; try rewrite ?IH //; do 2 f_equal; rewrite ?up_hcomp_dist //.
    move: IH => /(_ t (up sigma) (tau >>| ren (+1))). by asimpl.
  Qed.

  Lemma hsubst_type_label_subst_commute (sigma tau : var → type) σ:
    sigma >>| σ >> (tau >>| σ) = sigma >> tau >>| σ.
  Proof.
    apply FunctionalExtensionality.functional_extensionality.
    intros ?. asimpl. apply hsubst_label_subst_type_commute.
  Qed.

  Lemma subst_type_comp sigma tau t : t.[sigma].[tau] = t.[sigma >> tau]
  with hsubst_comp sigma tau τ : τ.|[sigma].|[tau] = τ.|[sigma >> tau].
  Proof.
    - destruct t; simpl;
        (repeat (match goal with τ : sectype |- _ => destruct τ end));
        simpl; rewrite ?subst_type_comp //.
      + rewrite  up_comp_internal; [done|done|..].
        * apply rename_subst_comp_type.
        * apply rename_subst_comp_type_rename.
      + rewrite hsubst_type_label_subst_commute //.
      + rewrite up_comp_internal; [done|done|..].
        * apply rename_subst_comp_type.
        * apply rename_subst_comp_type_rename.
      + rewrite up_comp_internal; [done|done|..].
        * apply rename_subst_comp_type.
        * apply rename_subst_comp_type_rename.
    - by destruct τ; simpl; f_equal.
  Qed.

  Global Instance SubstLemmas_type : SubstLemmas type.
  Proof.
    constructor; try done.
    - apply rename_subst.
    - apply subst_type_id.
    - apply subst_type_comp.
  Qed.

  Global Instance HSubstLemmas_sectype_type : HSubstLemmas type sectype.
  Proof.
    constructor; try done.
    - apply hsubst_id.
    - apply hsubst_comp.
  Qed.

  (* -------------------- /autosubst lemmas -------------------- *)

End lambda_sec_types.

Notation "τ @ ℓ" := (TSec ℓ τ) (at level 60).


Generalizable All Variables.
Set Implicit Arguments.

Require Import Coq.Lists.List Coq.Strings.String Coq.Arith.Arith.
Require Import Fiat.Common.ilist.
Require Import Fiat.Common.
Require Export Fiat.Common.VectorFacts.

Section ilist2.

  (* Lists of elements whose types depend on an indexing set (CPDT's hlists).
     These lists are a convenient way to implement finite maps
     whose elements depend on their keys. The data structures used
     by our ADT notations uses these to implement notation-friendly
     method lookups.  *)

  Import Vectors.Vector.VectorNotations.

  Context {A : Type}. (* The indexing type. *)
  Context {B : A -> Type}. (* The type of indexed elements. *)

  Fixpoint ilist2 {n} (l : Vector.t A n) : Type :=
    match l with
      | [] => unit
      | a :: l => @prim_prod (B a) (ilist2 l)
    end.

  Definition icons2
             (a : A)
             {n}
             {l : Vector.t A n}
             (b : B a)
             (il : ilist2 l)
  : ilist2 (a :: l)
    := {| prim_fst := b; prim_snd := il |}.

  Definition inil2 : ilist2 [] := tt.

  (* Get the car of an ilist2. *)
  Definition ilist2_hd {n} {As : Vector.t A n} (il : ilist2 As) :
    match As return ilist2 As -> Type with
      | a :: As' => fun il => B a
      | [] => fun _ => unit
    end il :=
    match As return
          forall (il : ilist2 As),
            match As return ilist2 As -> Type with
              | a :: As' => fun il => B a
              | [] => fun _ => unit
            end il with
      | a :: As => fun il => prim_fst il
      | [] => fun il => tt
    end il.

  Definition ilist2_hd' {n} {As : Vector.t A (S n)} (il : ilist2 As) :
    B (Vector.hd As)
    := Vector.caseS (fun n As => ilist2 As -> B (Vector.hd As))
                           (fun a As m => ilist2_hd) As il.

  (* Get the cdr of an ilist2. *)
  Definition ilist2_tl {n} {As : Vector.t A n} (il : ilist2 As) :
    match As return ilist2 As -> Type with
      | a :: As' => fun il => ilist2 As'
      | [] => fun _ => unit
    end il :=
    match As return
          forall (il : ilist2 As),
            match As return ilist2 As -> Type with
              | a :: As' => fun il => ilist2 As'
              | [] => fun _ => unit
            end il with
      | a :: As => fun il => prim_snd il
      | [] => fun il => tt
    end il.

  Definition ilist2_tl'
             {n} {As : Vector.t A (S n)} (il : ilist2 As)
    : ilist2 (Vector.tl As) :=
    Vector.caseS (fun n As => ilist2 As -> ilist2 (Vector.tl As))
                 (fun a As m => ilist2_tl) As il.

  Infix "++" := Vector.append : vector_scope.

  (* Appending ilist2s *)
  Fixpoint ilist2_app {n} {As : Vector.t A n}
    : forall {n'} {As' : Vector.t A n'},  ilist2 As -> ilist2 As' -> ilist2 (As ++ As') :=
      match As return
            forall {n'} (As' : Vector.t A n'),
              ilist2 As -> ilist2 As' -> ilist2 (As ++ As') with
        | [] =>
          fun n' As' il il' => il'
        | a :: As'' =>
          fun n' As' il il' =>
            {| prim_fst := ilist2_hd il;
               prim_snd := ilist2_app (ilist2_tl il) il' |}
      end.

  (* Split *)
  Fixpoint ilist2_split {n} {As : Vector.t A n}
    : forall {n'} {As' : Vector.t A n'},  ilist2 (As ++ As') -> ilist2 As * ilist2 As' :=
      match As return
            forall {n'} (As' : Vector.t A n'),
              ilist2 (As ++ As') -> ilist2 As * ilist2 As' with
      | [] =>
        fun n' As' il =>  (inil2, il)
      | a :: As'' =>
        fun n' As' il =>
          let '(il0, il1) := ilist2_split (ilist2_tl il) in
          ({| prim_fst := ilist2_hd il; prim_snd := il0 |}, il1)
      end.

  Lemma split_app {n} {As : Vector.t A n} :
    forall {n'} {As' : Vector.t A n'} (il: ilist2 As) (il': ilist2 As'),
      ilist2_split (ilist2_app il il') = (il, il').
  Proof.
    induction As; cbn; destruct il; cbn; intros; rewrite ?IHAs; reflexivity.
  Qed.

  (* Membership in an indexed list. *)

  Inductive ilist2_In {a : A} (b : B a)
  : forall {n} {As : Vector.t A n} (il : ilist2 As), Prop :=
  | In_hd : forall n' As' (il : ilist2 (n := n') As'),
              ilist2_In b (icons2 b il)
  | In_tl : forall {n'} a' (b' : B a') As' (il : ilist2 (n := n') As'),
              ilist2_In b il ->
              ilist2_In b (icons2 b' il).

  (* Looking up the ith value, returning None for indices not in the Vector.t *)

  Fixpoint ith2
           {m : nat}
           {As : Vector.t A m}
           (il : ilist2 As)
           (n : Fin.t m)
           {struct n}
    : B (Vector.nth As n) :=
    match n in Fin.t m return
          forall (As : Vector.t A m),
            ilist2 As
            -> B (Vector.nth As n) with
    | Fin.F1 k =>
      fun As =>
        Vector.caseS (fun n As => ilist2 As
                                  -> B (Vector.nth As (@Fin.F1 n)))
                     (fun h n t => ilist2_hd) As
    | Fin.FS k n' =>
      fun As =>
        Vector_caseS' Fin.t
                      (fun n As n' =>
                         ilist2 As
                          -> B (Vector.nth As (@Fin.FS n n')))
                     (fun h n t m il => ith2 (ilist2_tl il) m)
                     As n'
    end As il.

  Lemma ilist2_invert {n} (As : Vector.t A n) (il : ilist2 As) :
    match As as As' return ilist2 As' -> Prop with
      | a :: As' => fun il => exists b il', il = icons2 b il'
      | [] => fun il => il = inil2
    end il.
  Proof.
    destruct As; destruct il; simpl; unfold icons2; eauto.
  Qed.

  Lemma ilist2_invert' {n} (As : Vector.t A n) (il : ilist2 As) :
    match As as As' return ilist2 As' -> Type with
      | a :: As' => fun il => sigT (fun b => sigT (fun il' => il = icons2 b il'))
      | [] => fun il => il = inil2
    end il.
  Proof.
    destruct As; destruct il; unfold icons2; eauto.
  Qed.

End ilist2.

(** ** Mapping a function over a(n i)[list], in two non-dependent ways *)
Section ilist2_map.
  Context {A} (B : A -> Type).

  Import Vectors.Vector.VectorNotations.

  Fixpoint imap2_list (f : forall a : A, B a) {n} (As : Vector.t A n) : ilist2 As
    := match As with
         | [] => inil2
         | x :: xs => @icons2 _ B x _ _ (f x) (imap2_list f xs)
       end.

End ilist2_map.

Ltac icons2_invert :=
  repeat match goal with
           | [il : ilist2 _ (_ :: _) |- _]
             => let il' := fresh "il" in
                let b' := fresh "b" in
                let il'_eq := fresh "il_eq" in
                generalize (ilist2_invert il);
                  intros il'; destruct il' as [b' [il' il'_eq]]; subst
         end.

Section ilist2_imap.

  (* Mapping a function over an indexed Vector.t. *)

  Import Vectors.Vector.VectorNotations.

  Variable A : Type. (* The indexing type. *)
  Variable B B' : A -> Type. (* The two types of indexed elements. *)
  Variable f : forall a, B a -> B' a. (* The function to map over the Vector.t. *)

  Fixpoint imap2 {n} (As : Vector.t A n)
    : ilist2 As -> ilist2 As :=
    match As return ilist2 As -> ilist2 As with
    | [] => fun il => inil2
    | a :: As' => fun il => icons2 (@f a (ilist2_hd il)) (imap2 As' (ilist2_tl il))
    end.

  (* [imap] behaves as expected with the [ith2_default] lookup
     function. *)
  Lemma ith_imap2 :
    forall {n}
           (m : Fin.t n)
           (As : Vector.t A n)
           (il : ilist2 As),
      f (ith2 il m) = ith2 (imap2 As il) m.
  Proof.
    induction m; intro.
    - eapply Vector.caseS with (v := As); intros; simpl in *; destruct il; reflexivity.
    - revert m IHm.
      pattern n, As.
      match goal with
        |- ?P n As =>
        simpl; eapply (@Vector.rectS _ P); intros
      end.
      inversion m.
      eapply IHm.
  Qed.

End ilist2_imap.

Section ilist2_replace.

  Import Vectors.Vector.VectorNotations.

  (* Replacing an element of an indexed Vector.t. *)
  Context {A : Type}. (* The indexing type. *)
  Context {B : A -> Type}. (* The two types of indexed elements. *)

  Fixpoint replace_Index2
             {m}
             (As : Vector.t A m)
             (il : ilist2 As)
             (n : Fin.t m)
             (new_b : B (Vector.nth As n))
             {struct n}
    : ilist2 As :=
    match n in Fin.t m return
          forall (As : Vector.t A m),
            @ilist2 _ B _ As
            -> B (Vector.nth As n)
            -> ilist2 As with
    | Fin.F1 k =>
      fun As =>
        Vector.caseS (fun n As => ilist2 As
                                  -> B (Vector.nth As (@Fin.F1 n))
                                  -> ilist2 As)
                     (fun h n t il new_b => icons2 new_b (ilist2_tl il) ) As
    | Fin.FS k n' =>
      fun As =>
        Vector_caseS' Fin.t
                      (fun n As n' =>
                          ilist2 As
                          -> B (Vector.nth As (@Fin.FS n n'))
                          -> ilist2 As)
                     (fun h n t m il new_b => icons2 (ilist2_hd il)
                                                    (@replace_Index2 _ _ (ilist2_tl il) _ new_b))
                     As n'
    end As il new_b.

  Lemma ith_replace2_Index_neq {m}
    : forall
      (n n' : Fin.t m)
      (As : Vector.t A m)
      (il : ilist2 As)
      (new_b : B (Vector.nth As n')),
      n <> n'
      -> ith2 (replace_Index2 As il n' new_b) n = ith2 il n.
  Proof.
    intros n n'; pattern m, n, n'.
    match goal with
      |- ?P m n n' => simpl; eapply (Fin.rect2 P); intros
    end.
    - congruence.
    - generalize il f new_b; clear f new_b il H.
      pattern n0, As.
      match goal with
        |- ?P n0 As =>
        simpl; apply (@Vector.rectS _ P); intros; reflexivity
      end.
    - generalize il f new_b; clear f new_b il H.
      pattern n0, As.
      match goal with
        |- ?P n0 As =>
        simpl; apply (@Vector.rectS _ P); intros; reflexivity
      end.
    - assert (f <> g) by congruence.
      generalize il f g new_b H H1; clear f g new_b il H H1 H0.
      pattern n0, As.
      match goal with
        |- ?P n0 As =>
        simpl; apply (@Vector.caseS _ P); intros;
        eapply (H _ (prim_snd il) new_b); eauto
      end.
  Qed.

  Lemma ith_replace2_Index_eq {m}
    : forall
      (n : Fin.t m)
      (As : Vector.t A m)
      (il : ilist2 As)
      (new_b : B (Vector.nth As n)),
      ith2 (replace_Index2 As il n new_b) n = new_b.
  Proof.
    induction n; simpl.
    - intro As; pattern n, As.
      match goal with
        |- ?P n As =>
        simpl; apply (@Vector.caseS _ P); intros; reflexivity
      end.
    - intro As; revert n0 IHn; pattern n, As.
      match goal with
        |- ?P n As =>
        simpl; apply (@Vector.caseS _ P); simpl; eauto
      end.
  Qed.

End ilist2_replace.

Lemma imap_replace2_Index
      {A}
      {m}
      {B B' : A -> Type}
  : forall (f : forall idx'', B idx'' -> B' idx'')
           (idx : Fin.t m )
           (Bound : Vector.t A m)
           (il : ilist2 Bound)
           b,
    imap2 B B' f Bound (replace_Index2 Bound il idx b) =
    replace_Index2 Bound (imap2 B B' f Bound il) idx (f _ b).
Proof.
  induction idx.
  - intro Bound; pattern n, Bound.
    match goal with
      |- ?P n Bound =>
      simpl; apply (@Vector.caseS _ P); intros; reflexivity
    end.
  - intro Bound; revert idx IHidx; pattern n, Bound.
    match goal with
      |- ?P n Bound =>
      simpl; apply (@Vector.caseS _ P); intros; simpl; f_equal; eauto
    end.
Qed.

Section ilist2_update.

  Import Vectors.Vector.VectorNotations.

  (* Replacing an element of an indexed Vector.t. *)
  Context {A : Type}. (* The indexing type. *)
  Context {B : A -> Type}. (* The two types of indexed elements. *)

  Fixpoint update_Index2
             {m}
             (As : Vector.t A m)
             (il : ilist2 As)
             (n : Fin.t m)
             (update_b : B (Vector.nth As n) -> B (Vector.nth As n))
             {struct n}
    : ilist2 As :=
    match n in Fin.t m return
          forall (As : Vector.t A m),
            @ilist2 _ B _ As
            -> (B (Vector.nth As n) -> B (Vector.nth As n))
            -> ilist2 As with
    | Fin.F1 k =>
      fun As =>
        Vector.caseS (fun n As => ilist2 As
                                  -> (B (Vector.nth As (@Fin.F1 n)) -> B (Vector.nth As (@Fin.F1 n)))
                                  -> ilist2 As)
                     (fun h n t il update_b => icons2 (update_b (ilist2_hd il)) (ilist2_tl il) ) As
    | Fin.FS k n' =>
      fun As =>
        Vector_caseS' Fin.t
                      (fun n As n' =>
                          ilist2 As
                          -> (B (Vector.nth As (@Fin.FS n n')) -> B (Vector.nth As (@Fin.FS n n')))
                          -> ilist2 As)
                      (fun h n t m il update_b => icons2 (ilist2_hd il)
                                                    (@update_Index2 _ _ (ilist2_tl il) _ update_b))
                      As n'
    end As il update_b.

  Lemma ith_update_Index2_neq {m}
    : forall
      (n n' : Fin.t m)
      (As : Vector.t A m)
      (il : ilist2 As)
      (update_b : B (Vector.nth As n') -> B (Vector.nth As n')),
      n <> n'
      -> ith2 (update_Index2 As il n' update_b) n = ith2 il n.
  Proof.
    intros n n'; pattern m, n, n'.
    match goal with
      |- ?P m n n' => simpl; eapply (Fin.rect2 P); intros
    end.
    - congruence.
    - generalize il f update_b; clear f update_b il H.
      pattern n0, As.
      match goal with
        |- ?P n0 As =>
        simpl; apply (@Vector.rectS _ P); intros; reflexivity
      end.
    - generalize il f update_b; clear f update_b il H.
      pattern n0, As.
      match goal with
        |- ?P n0 As =>
        simpl; apply (@Vector.rectS _ P); intros; reflexivity
      end.
    - assert (f <> g) by congruence.
      generalize il f g update_b H H1; clear f g update_b il H H1 H0.
      pattern n0, As.
      match goal with
        |- ?P n0 As =>
        simpl; apply (@Vector.caseS _ P); intros;
        eapply (H _ (prim_snd il) update_b); eauto
      end.
  Qed.
  Set Printing All.

  Lemma ith_update_Index2_eq {m}
    : forall
      (n : Fin.t m)
      (As : Vector.t A m)
      (il : ilist2 As)
      (update_b : B (Vector.nth As n) -> B (Vector.nth As n)),
      ith2 (update_Index2 As il n update_b) n = update_b (ith2 il n).
  Proof.
    induction n; simpl.
    - intro As; pattern n, As.
      match goal with
        |- ?P n As =>
        simpl; apply (@Vector.caseS _ P); intros; reflexivity
      end.
    - intro As; revert n0 IHn; pattern n, As.
      match goal with
        |- ?P n As =>
        simpl; apply (@Vector.caseS _ P); simpl; eauto
      end.
  Qed.

End ilist2_update.


(*===========================================================================
    Partial functions, represented as X -> option Y
  ===========================================================================*)
Require Import ssreflect ssrfun ssrbool.
Require Import Setoid Morphisms.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Section PFun.

  Variable X Y : Type.

  (* Asymmetric combination of partial functions, right-hand operand taking priority *)
  Definition extend (f1 f2: X -> option Y) :=
  fun x => if f2 x is Some z then Some z else f1 x.

  Definition includedIn (f1 f2: X -> option Y) :=
  forall x y, f1 x = Some y -> f2 x = Some y.

  Lemma includedIn_refl f : includedIn f f.
  Proof. rewrite /includedIn; intuition.
  Qed.

  Lemma includedIn_trans f1 f2 f3 : includedIn f1 f2 -> includedIn f2 f3 -> includedIn f1 f3.
  Proof.  rewrite /includedIn. move => H1 H2. move => x y.
  auto. Qed.

  Definition splitsAs (f f1 f2: X -> option Y) :=
  forall x,
  if f x is Some y
    then (f1 x = Some y /\ f2 x = None)
      \/ (f2 x = Some y /\ f1 x = None)
    else f1 x = None /\ f2 x = None.

  Lemma splitsAsExtend f f1 f2 : splitsAs f f1 f2 -> f =1 extend f1 f2.
  Proof. rewrite /extend /splitsAs. move => H. move => x.
  specialize (H x). case e: (f x) => [z |]; rewrite e in H.
  + destruct H; by rewrite (proj2 H) (proj1 H).
  + by rewrite (proj2 H) (proj1 H). Qed.

  Definition empFun : X -> option Y := fun _ => None.

  Lemma splitsAs_commutative f f1 f2 : splitsAs f f1 f2 -> splitsAs f f2 f1.
  Proof. rewrite /splitsAs. move => H x.
  specialize (H x). case e: (f x) => [y |]; rewrite e in H.
  case H; [by right | by left]. intuition.
  Qed.

  Lemma splitsAs_f_emp_g f g : splitsAs f empFun g -> f =1 g.
  Proof. rewrite /splitsAs. move => H x. specialize (H x).
  case e: (f x) => [z |]; rewrite e in H; [by destruct H; destruct H | intuition].
  Qed.

  Lemma splitsAs_f_g_emp f g : splitsAs f g empFun -> f =1 g.
  Proof. rewrite /splitsAs. move => H x. specialize (H x).
  case e: (f x) => [z |]; rewrite e in H; [by destruct H; destruct H | intuition].
  Qed.

  Lemma splitsAs_f_f_emp f : splitsAs f f empFun.
  Proof. move => x. case (f x); intuition. Qed.

  Lemma splitsAs_f_emp_f f : splitsAs f empFun f.
  Proof. move => x. case (f x); intuition. Qed.

  Lemma splitsAs_f_g_f f g : splitsAs f g f -> g =1 empFun.
  Proof. rewrite /splitsAs. move => H x. specialize (H x).
  case e:(f x) => [y |]; rewrite e in H. by elim H; intuition. by intuition.
  Qed.

  Lemma splitsAs_f_f_g f g: splitsAs f f g -> g =1 empFun.
  Proof. rewrite /splitsAs. move => H x. specialize (H x).
  case e:(f x) => [y |]; rewrite e in H. by elim H; intuition. by intuition.
  Qed.

  Lemma splitsAs_functional f g h i : splitsAs h f g -> splitsAs i f g -> h =1 i.
  Proof.
    rewrite /splitsAs. move => Hh Hi x.
    specialize (Hh x); specialize (Hi x).
    case eh:(h x) => [y |]; rewrite eh in Hh;
    case ei:(i x) => [z |]; rewrite ei in Hi;
    intuition congruence.
  Qed.

  Lemma splitsAs_functionalArg s s1 s2 s3 : splitsAs s s2 s1 -> splitsAs s s3 s1 -> s2 =1 s3.
  Proof.
    rewrite /splitsAs. move => H1 H2 x.
    specialize (H1 x). specialize (H2 x).
    case E1: (s x) => [y |]. rewrite E1 in H1, H2.
      destruct H1. destruct H as [Ha Hb].
      destruct H2; destruct H; congruence.
      destruct H2; destruct H; destruct H0; congruence.
    rewrite E1 in H1, H2. destruct H1; destruct H2; congruence.
  Qed.

  Lemma splitsAs_eq f g h i : splitsAs h f g -> h =1 i -> splitsAs i f g.
  Proof.
    rewrite /splitsAs. move => H heqi x.
    specialize (H x).
    case e:(h x) => [y |]; rewrite e in H;
    rewrite heqi in e; rewrite e; intuition.
  Qed.

  Lemma splitsAs_eq_arg f g h i : splitsAs i f g -> f =1 h -> splitsAs i h g.
  Proof.
    rewrite /splitsAs. move => H feqh x.
    specialize (H x).
    case e:(i x) => [y |]; rewrite e in H; intuition congruence.
  Qed.

  Lemma splitsAsIncludedInSplitsAs f f1 f2 g :
    let g2 :=fun x => if f1 x is Some _ then None else if f2 x is Some y then Some y else g x
    in
    splitsAs f f1 f2 -> includedIn f g ->
    splitsAs g f1 g2 /\ includedIn f2 g2.
  Proof. move => g2 fsplit fg.
  rewrite /splitsAs in fsplit. rewrite /includedIn in fg.
  split.
  rewrite /splitsAs => x.
  specialize (fsplit x).
  case E: (f x) => [z |].
  rewrite E in fsplit. specialize (fg _ _ E). rewrite fg.
    destruct fsplit; destruct H as [H1 H2].
    + left. by rewrite /g2 H2 H1.
    + right. by rewrite /g2 H2 H1.
  rewrite E in fsplit.
  destruct fsplit as [H1 H2]. case E2: (g x) => [y |]. right. by rewrite /g2 H1 H2.
  by rewrite /g2 H1 H2.

  rewrite /includedIn => x y E.
  case E2: (f x) => [z |].
  specialize (fg _ _ E2). specialize (fsplit x). rewrite E2 in fsplit.
  destruct fsplit; destruct H as [H1 H2].
  + congruence. rewrite /g2 H2 H1. congruence.
  + specialize (fsplit x). rewrite E2 in fsplit. destruct fsplit as [H1 H2].
  congruence.
  Qed.

  Lemma splitsAs_associative f f1 f2 f3 f4 :
    let f5 := fun x => if f4 x is Some y then Some y else f1 x in
    splitsAs f f1 f2 -> splitsAs f2 f3 f4 ->
    splitsAs f f3 f5 /\ splitsAs f5 f1 f4.
  Proof. rewrite /splitsAs. move => H1 H2.
  split.
  * move => x. specialize (H1 x). specialize (H2 x).
  case e: (f x) => [y |].
  + rewrite e in H1.
    case e': (f2 x) => [y' |].
    - rewrite e' in H2.
      destruct H1. destruct H. congruence.
      destruct H2. destruct H. destruct H0.
      rewrite H2. left. rewrite H in e'. rewrite e'. done.
      destruct H. destruct H0.
      rewrite H2. right. rewrite H0. rewrite H in e'. rewrite e'. done.
    - rewrite e' in H2. destruct H2. destruct H1. right. rewrite H0. intuition.
      destruct H1. rewrite e' in H1. done.
  + rewrite e in H1. destruct H1. rewrite H0 in H2. destruct H2. rewrite H2. done.
  * move => x. specialize (H1 x). specialize (H2 x).
  case e: (f x) => [y |]. rewrite e in H1.
  case e': (f2 x) => [y' |]. rewrite e' in H2.
  destruct H2. destruct H. rewrite H0.
  destruct H1. destruct H1. rewrite H1. left. done.
  destruct H1. rewrite H2. done.
  destruct H. rewrite H.
  destruct H1. destruct H1. rewrite H2 in e'. done. right. destruct H1. done.
  rewrite e' in H2. destruct H2. rewrite H0.
  destruct H1. destruct H1. rewrite H1. left. done.
  destruct H1. rewrite H2. done.
  rewrite e in H1. destruct H1. rewrite H0 in H2. destruct H2. rewrite H2.
  rewrite H. done.
  Qed.

  Lemma splitsAsIncludes f f1 f2 : splitsAs f f1 f2 -> includedIn f1 f /\ includedIn f2 f.
  Proof. move => S. split; move => x y H; specialize (S x);
  case e: (f x) => [y' | ]; rewrite e in S; intuition; congruence.
  Qed.

  Lemma splitsAsExtendL s s1 s2 s3 s4 : splitsAs s s1 s2 -> splitsAs s2 s3 s4 ->
  splitsAs s (extend s1 s3) s4.
  Proof. move => H1 H2 x.
  rewrite /splitsAs in H1, H2. specialize (H1 x). specialize (H2 x). rewrite /extend.
  case E1: (s x) => [y |]; rewrite E1 in H1.
  + case E2: (s2 x) => [z |]; rewrite E2 in H2.
    - case H2 => {H2} H2'. destruct H2' as [H2a H2b].
      case H1 => {H1} H1'; destruct H1' as [H1a H1b]. congruence.
      left. rewrite H2a. split;  congruence.
    - case H1 => {H1} H1'; destruct H1' as [H1a H1b]. congruence.
      destruct H2' as [H2a H2b]. rewrite H2b. right. split; congruence.
    destruct H2 as [H2a H2b]. rewrite H2a. left.
    case H1 => {H1} H1'; destruct H1' as [H1a H1b]. done. congruence.
  + case E2: (s2 x) => [z |]; rewrite E2 in H2.
    destruct H1 as [H1a H1b]. rewrite H1a. rewrite H1b in E2. done.
    destruct H2 as [H2a H2b]. rewrite H2a. intuition.
  Qed.

  Global Instance eqfun_equivalence {A B} : Equivalence (@eqfun A B).
  Proof.
    split.
    + intros a x; reflexivity.
    + intros a b H x; symmetry; apply H.
    + intros a b c H1 H2 x; transitivity (b x); [apply H1 | apply H2].
  Qed.

  Global Instance splitsAs_m :
    (Proper (@eqfun (option Y) X ==> @eqfun (option Y) X ==> @eqfun (option Y) X ==> iff)) splitsAs.
  Proof.
    move => a b aeqb c d ceqd e f eeqf; split.
    + move => H.
      eapply splitsAs_eq; [|eassumption].
      eapply splitsAs_eq_arg; [|eassumption].
      apply splitsAs_commutative.
      eapply splitsAs_eq_arg; [|eassumption].
      apply splitsAs_commutative; assumption.
    + move => H.
      eapply splitsAs_eq; [|symmetry; eassumption].
      eapply splitsAs_eq_arg; [|symmetry; eassumption].
      apply splitsAs_commutative.
      eapply splitsAs_eq_arg; [|symmetry; eassumption].
      apply splitsAs_commutative; assumption.
  Qed.

End PFun.

  Hint Resolve splitsAsIncludes.
  Hint Resolve includedIn_refl.


(*! Utilities | Dependent type tracking membership into a list !*)
Require Import Koika.Common.

Inductive member {K: Type}: K -> list K -> Type :=
| MemberHd: forall k sig, member k (k :: sig)
| MemberTl: forall k k' sig, member k sig -> member k (k' :: sig).

(* https://github.com/coq/coq/issues/10749 *)
Definition eq_type {A} (a a': A) : Type :=
  eq a a'.

Definition mdestruct {K sig} {k: K} (m: member k sig)
  : match sig return member k sig -> Type with
    | [] => fun m => False
    | k' :: sig =>
      fun m => ({ eqn: (eq_type k k') & m = eq_rect _ _ (fun _ => MemberHd k sig) _ eqn m } +
             { m': member k sig & m = MemberTl k k' sig m' })%type
    end m.
  destruct m; cbn.
  - left; exists eq_refl; eauto.
  - right; eauto.
Defined.

Lemma member_In {K} (sig: list K):
  forall k, member k sig -> List.In k sig.
Proof.
  induction 1; firstorder.
Qed.

Fixpoint member_idx {K sig} {k: K} (m: member k sig) : nat :=
  match m with
  | MemberHd k sig => 0
  | MemberTl k k' sig m' => S (member_idx m')
  end.

Lemma member_idx_nth {K sig} (k: K) (m: member k sig) :
  List.nth_error sig (member_idx m) = Some k.
Proof.
  induction m; firstorder.
Qed.

Lemma nth_member {T}:
  forall (ls: list T) idx t,
    List.nth_error ls idx = Some t ->
    member t ls.
Proof.
  induction ls; destruct idx; cbn; inversion 1; subst;
    eauto using MemberHd, MemberTl.
Defined.

Lemma member_idx_inj {K sig} `{EqDec K} {k: K}
      (m m': member k sig) :
  member_idx m = member_idx m' ->
  m = m'.
Proof.
  induction m; cbn; intros * Hidx;
    destruct (mdestruct m') as [(Hr & Heq) | (m'' & ->)]; cbn in *; subst; cbn in *;
      try destruct Hr; try rewrite <- Eqdep_dec.eq_rect_eq_dec in * by apply eq_dec;
        cbn in *; subst; cbn in *; inversion Hidx; subst.
  - reflexivity.
  - f_equal; eauto.
Qed.

Lemma member_idx_inj_contra {K sig} `{EqDec K} {k: K}
      (m m': member k sig) :
  m <> m' ->
  member_idx m <> member_idx m'.
Proof.
  intros ** Heq%member_idx_inj; congruence.
Qed.

Lemma member_idx_inj_k {K sig} {k k': K}
      (m: member k sig) (m': member k' sig) :
  member_idx m = member_idx m' ->
  k = k'.
Proof.
  intros * Heq;
    eapply f_equal in Heq; erewrite !member_idx_nth in Heq;
      congruence.
Qed.

Lemma member_idx_inj_k_contra {K sig} {k k': K}
      (m: member k sig) (m': member k' sig) :
  k <> k' -> member_idx m <> member_idx m'.
Proof.
  intros ** Heq%member_idx_inj_k; congruence.
Qed.

Fixpoint member_map {K K'} (f: K -> K') {k: K} {ls: list K}
         (m: member k ls) : member (f k) (List.map f ls) :=
  match m in (member k ls) return (member (f k) (List.map f ls)) with
  | MemberHd k sig =>
    MemberHd (f k) (List.map f sig)
  | MemberTl k k' sig m' =>
    MemberTl (f k) (f k') (List.map f sig) (member_map f m')
  end.

Lemma member_map_idx  {K K'} (f: K -> K') (k: K) (ls: list K)
      (m: member k ls) :
  member_idx (member_map f m) = member_idx m.
Proof.
  induction m; cbn; eauto.
Qed.

Fixpoint member_unmap {K K'} (f: K -> K') (k': K') (ls: list K)
         (m: member k' (List.map f ls)) : { k: K & member k ls }.
  destruct ls; cbn in *.
  - destruct (mdestruct m).
  - destruct (mdestruct m) as [(eqn & Heq) | (m' & Heq)]; cbn in *;
      [ destruct eqn | destruct Heq ].
    + exact (existT _ k (MemberHd k ls)).
    + destruct (member_unmap _ _ f k' ls m') as [ k0 m0 ].
      exact (existT _ k0 (MemberTl k0 k ls m0)).
Defined.

Lemma member_app_l {A} (a: A):
  forall ls ls',
    member a ls ->
    member a (ls ++ ls').
Proof.
  induction ls; cbn; intros ls' m.
  - destruct (mdestruct m).
  - destruct (mdestruct m) as [(-> & Heq) | (m' & Heq)];
      subst; eauto using MemberHd, MemberTl.
Defined.

Lemma member_app_r {A} (a: A):
  forall ls ls',
    member a ls' ->
    member a (ls ++ ls').
Proof.
  induction ls; cbn; eauto using MemberTl.
Defined.

Lemma member_NoDup {K} {sig: list K} k:
  EqDec K ->
  NoDup sig ->
  forall (m1 m2: member k sig),
    m1 = m2.
Proof.
  induction 2.
  - intros; destruct (mdestruct m1).
  - intros; destruct (mdestruct m1) as [(-> & ->) | (mem & ->)]; cbn.
    + intros; destruct (mdestruct m2) as [(? & ->) | (absurd & ->)]; cbn.
      * rewrite <- Eqdep_dec.eq_rect_eq_dec by apply eq_dec.
        reflexivity.
      * exfalso; apply member_In in absurd; auto.
    + intros; destruct (mdestruct m2) as [(-> & ->) | (? & ->)]; cbn.
      * exfalso; apply member_In in mem. auto.
      * f_equal; apply IHNoDup.
Qed.

Fixpoint mem {K} `{EqDec K} (k: K) sig {struct sig} : member k sig + (member k sig -> False).
  destruct sig.
  - right; intro m; destruct (mdestruct m).
  - destruct (eq_dec k k0) as [Heq | Hneq].
    + subst. left. apply MemberHd.
    + destruct (mem _ _ k sig) as [m | ].
      * left. apply MemberTl. exact m.
      * right. intros m.
        destruct (mdestruct m) as [(eqn & Heq) | (m' & Heq)]; congruence.
Defined.

Fixpoint mem_opt {K} `{EqDec K} (k: K) sig {struct sig} : option (member k sig) :=
  match sig with
  | [] => None
  | k' :: sig =>
    match eq_dec k k' return option (member k (k' :: sig)) with
    | left eqn => Some (rew <-[fun k => member k (k' :: sig)] eqn in MemberHd k' sig)
    | right _ =>
      match mem_opt k sig with
      | Some m => Some (MemberTl k k' sig m)
      | None => None
      end
    end
  end.

Lemma mem_opt_correct  {K} `{EqDec K} (k: K) (sig: list K) :
  mem_opt k sig = match mem k sig with
                  | inl m => Some m
                  | inr _ => None
                  end.
Proof.
  induction sig as [| k0 sig0 IHsig]; cbn.
  - reflexivity.
  - destruct (eq_dec k k0) as [Heq | Hneq].
    + destruct Heq; reflexivity.
    + rewrite IHsig; destruct mem; reflexivity.
Qed.

Fixpoint find {K} (fn: K -> bool) sig {struct sig} : option { k: K & member k sig }.
  destruct sig.
  - right.
  - destruct (fn k) eqn:?.
    + left. eexists. apply MemberHd.
    + destruct (find _ fn sig) as [ (k' & m) | ].
      * left. eexists. apply MemberTl. eassumption.
      * right.
Defined.

Fixpoint assoc {K1 K2: Type} `{EqDec K1}
         (k1: K1) sig {struct sig} : option { k2: K2 & member (k1, k2) sig }.
Proof.
  destruct sig as [ | (k1' & k2) sig ].
  - right.
  - destruct (eq_dec k1 k1'); subst.
    + left. eexists. apply MemberHd.
    + destruct (assoc _ _ _ k1 sig) as [ (k2' & m) | ].
      * left. eexists. apply MemberTl. eassumption.
      * right.
Defined.

Fixpoint mmap {K V} (l: list K) (f: forall k: K, member k l -> V) {struct l} : list V :=
  match l return ((forall k : K, member k l -> V) -> list V) with
   | [] => fun _ => []
   | k :: l => fun f => f k (MemberHd k l) :: mmap l (fun k' m => f k' (MemberTl k' k l m))
   end f.

Fixpoint mprefix {K} (prefix: list K) {sig: list K} {k} (m: member k sig)
  : member k (prefix ++ sig) :=
  match prefix return member k sig -> member k (prefix ++ sig) with
  | [] => fun m => m
  | k' :: prefix => fun m => MemberTl k k' (prefix ++ sig) (mprefix prefix m)
  end m.

Fixpoint minfix {K} (infix: list K) {sig sig': list K} {k} (m: member k (sig ++ sig'))
  : member k (sig ++ infix ++ sig').
Proof.
  destruct sig as [ | k' sig].
  - exact (mprefix infix m).
  - destruct (mdestruct m) as [(eqn & Heq) | (m' & Heq)];
      [ destruct eqn | ]; cbn in *.
    + exact (MemberHd k (sig ++ infix ++ sig')).
    + exact (MemberTl k k' (sig ++ infix ++ sig') (minfix _ infix sig sig' k m')).
Defined.

Definition mprefix_pair {K sig} (k: K) (p: {k': K & member k' sig})
  : {k': K & member k' (k :: sig)} :=
  let '(existT _ k' m) := p in
  existT _ k' (MemberTl k' k _ m).

Fixpoint all_members {K} (sig: list K): list { k: K & member k sig } :=
  match sig with
  | [] => []
  | k :: sig => let ms := all_members sig in
              let ms := List.map (mprefix_pair k) ms in
              (existT _ k (MemberHd k sig)) :: ms
  end.